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 "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 "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 */
2889 # define PERL_BUFSIZ 512
2891 # define PERL_BUFSIZ 8192
2896 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2898 unsigned long int mbxbufsiz;
2899 static unsigned long int syssize = 0;
2900 unsigned long int dviitm = DVI$_DEVNAM;
2901 char csize[LNM$C_NAMLENGTH+1];
2905 unsigned long syiitm = SYI$_MAXBUF;
2907 * Get the SYSGEN parameter MAXBUF
2909 * If the logical 'PERL_MBX_SIZE' is defined
2910 * use the value of the logical instead of PERL_BUFSIZ, but
2911 * keep the size between 128 and MAXBUF.
2914 _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2917 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2918 mbxbufsiz = atoi(csize);
2920 mbxbufsiz = PERL_BUFSIZ;
2922 if (mbxbufsiz < 128) mbxbufsiz = 128;
2923 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2925 _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2927 sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2928 _ckvmssts_noperl(sts);
2929 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2931 } /* end of create_mbx() */
2934 /*{{{ my_popen and my_pclose*/
2936 typedef struct _iosb IOSB;
2937 typedef struct _iosb* pIOSB;
2938 typedef struct _pipe Pipe;
2939 typedef struct _pipe* pPipe;
2940 typedef struct pipe_details Info;
2941 typedef struct pipe_details* pInfo;
2942 typedef struct _srqp RQE;
2943 typedef struct _srqp* pRQE;
2944 typedef struct _tochildbuf CBuf;
2945 typedef struct _tochildbuf* pCBuf;
2948 unsigned short status;
2949 unsigned short count;
2950 unsigned long dvispec;
2953 #pragma member_alignment save
2954 #pragma nomember_alignment quadword
2955 struct _srqp { /* VMS self-relative queue entry */
2956 unsigned long qptr[2];
2958 #pragma member_alignment restore
2959 static RQE RQE_ZERO = {0,0};
2961 struct _tochildbuf {
2964 unsigned short size;
2972 unsigned short chan_in;
2973 unsigned short chan_out;
2975 unsigned int bufsize;
2987 #if defined(PERL_IMPLICIT_CONTEXT)
2988 void *thx; /* Either a thread or an interpreter */
2989 /* pointer, depending on how we're built */
2997 PerlIO *fp; /* file pointer to pipe mailbox */
2998 int useFILE; /* using stdio, not perlio */
2999 int pid; /* PID of subprocess */
3000 int mode; /* == 'r' if pipe open for reading */
3001 int done; /* subprocess has completed */
3002 int waiting; /* waiting for completion/closure */
3003 int closing; /* my_pclose is closing this pipe */
3004 unsigned long completion; /* termination status of subprocess */
3005 pPipe in; /* pipe in to sub */
3006 pPipe out; /* pipe out of sub */
3007 pPipe err; /* pipe of sub's sys$error */
3008 int in_done; /* true when in pipe finished */
3011 unsigned short xchan; /* channel to debug xterm */
3012 unsigned short xchan_valid; /* channel is assigned */
3015 struct exit_control_block
3017 struct exit_control_block *flink;
3018 unsigned long int (*exit_routine)();
3019 unsigned long int arg_count;
3020 unsigned long int *status_address;
3021 unsigned long int exit_status;
3024 typedef struct _closed_pipes Xpipe;
3025 typedef struct _closed_pipes* pXpipe;
3027 struct _closed_pipes {
3028 int pid; /* PID of subprocess */
3029 unsigned long completion; /* termination status of subprocess */
3031 #define NKEEPCLOSED 50
3032 static Xpipe closed_list[NKEEPCLOSED];
3033 static int closed_index = 0;
3034 static int closed_num = 0;
3036 #define RETRY_DELAY "0 ::0.20"
3037 #define MAX_RETRY 50
3039 static int pipe_ef = 0; /* first call to safe_popen inits these*/
3040 static unsigned long mypid;
3041 static unsigned long delaytime[2];
3043 static pInfo open_pipes = NULL;
3044 static $DESCRIPTOR(nl_desc, "NL:");
3046 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
3050 static unsigned long int
3054 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
3055 int sts, did_stuff, need_eof, j;
3058 * Flush any pending i/o, but since we are in process run-down, be
3059 * careful about referencing PerlIO structures that may already have
3060 * been deallocated. We may not even have an interpreter anymore.
3065 #if defined(PERL_IMPLICIT_CONTEXT)
3066 /* We need to use the Perl context of the thread that created */
3070 aTHX = info->err->thx;
3072 aTHX = info->out->thx;
3074 aTHX = info->in->thx;
3077 #if defined(USE_ITHREADS)
3080 && PL_perlio_fd_refcnt)
3081 PerlIO_flush(info->fp);
3083 fflush((FILE *)info->fp);
3089 next we try sending an EOF...ignore if doesn't work, make sure we
3097 _ckvmssts_noperl(sys$setast(0));
3098 if (info->in && !info->in->shut_on_empty) {
3099 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3104 _ckvmssts_noperl(sys$setast(1));
3108 /* wait for EOF to have effect, up to ~ 30 sec [default] */
3110 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3115 _ckvmssts_noperl(sys$setast(0));
3116 if (info->waiting && info->done)
3118 nwait += info->waiting;
3119 _ckvmssts_noperl(sys$setast(1));
3129 _ckvmssts_noperl(sys$setast(0));
3130 if (!info->done) { /* Tap them gently on the shoulder . . .*/
3131 sts = sys$forcex(&info->pid,0,&abort);
3132 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3135 _ckvmssts_noperl(sys$setast(1));
3139 /* again, wait for effect */
3141 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3146 _ckvmssts_noperl(sys$setast(0));
3147 if (info->waiting && info->done)
3149 nwait += info->waiting;
3150 _ckvmssts_noperl(sys$setast(1));
3159 _ckvmssts_noperl(sys$setast(0));
3160 if (!info->done) { /* We tried to be nice . . . */
3161 sts = sys$delprc(&info->pid,0);
3162 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3163 info->done = 1; /* sys$delprc is as done as we're going to get. */
3165 _ckvmssts_noperl(sys$setast(1));
3171 #if defined(PERL_IMPLICIT_CONTEXT)
3172 /* We need to use the Perl context of the thread that created */
3175 if (open_pipes->err)
3176 aTHX = open_pipes->err->thx;
3177 else if (open_pipes->out)
3178 aTHX = open_pipes->out->thx;
3179 else if (open_pipes->in)
3180 aTHX = open_pipes->in->thx;
3182 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3183 else if (!(sts & 1)) retsts = sts;
3188 static struct exit_control_block pipe_exitblock =
3189 {(struct exit_control_block *) 0,
3190 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3192 static void pipe_mbxtofd_ast(pPipe p);
3193 static void pipe_tochild1_ast(pPipe p);
3194 static void pipe_tochild2_ast(pPipe p);
3197 popen_completion_ast(pInfo info)
3199 pInfo i = open_pipes;
3204 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3205 closed_list[closed_index].pid = info->pid;
3206 closed_list[closed_index].completion = info->completion;
3208 if (closed_index == NKEEPCLOSED)
3213 if (i == info) break;
3216 if (!i) return; /* unlinked, probably freed too */
3221 Writing to subprocess ...
3222 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3224 chan_out may be waiting for "done" flag, or hung waiting
3225 for i/o completion to child...cancel the i/o. This will
3226 put it into "snarf mode" (done but no EOF yet) that discards
3229 Output from subprocess (stdout, stderr) needs to be flushed and
3230 shut down. We try sending an EOF, but if the mbx is full the pipe
3231 routine should still catch the "shut_on_empty" flag, telling it to
3232 use immediate-style reads so that "mbx empty" -> EOF.
3236 if (info->in && !info->in_done) { /* only for mode=w */
3237 if (info->in->shut_on_empty && info->in->need_wake) {
3238 info->in->need_wake = FALSE;
3239 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3241 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3245 if (info->out && !info->out_done) { /* were we also piping output? */
3246 info->out->shut_on_empty = TRUE;
3247 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3248 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3249 _ckvmssts_noperl(iss);
3252 if (info->err && !info->err_done) { /* we were piping stderr */
3253 info->err->shut_on_empty = TRUE;
3254 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3255 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3256 _ckvmssts_noperl(iss);
3258 _ckvmssts_noperl(sys$setef(pipe_ef));
3262 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3263 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3266 we actually differ from vmstrnenv since we use this to
3267 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3268 are pointing to the same thing
3271 static unsigned short
3272 popen_translate(pTHX_ char *logical, char *result)
3275 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3276 $DESCRIPTOR(d_log,"");
3278 unsigned short length;
3279 unsigned short code;
3281 unsigned short *retlenaddr;
3283 unsigned short l, ifi;
3285 d_log.dsc$a_pointer = logical;
3286 d_log.dsc$w_length = strlen(logical);
3288 itmlst[0].code = LNM$_STRING;
3289 itmlst[0].length = 255;
3290 itmlst[0].buffer_addr = result;
3291 itmlst[0].retlenaddr = &l;
3294 itmlst[1].length = 0;
3295 itmlst[1].buffer_addr = 0;
3296 itmlst[1].retlenaddr = 0;
3298 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3299 if (iss == SS$_NOLOGNAM) {
3303 if (!(iss&1)) lib$signal(iss);
3306 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3307 strip it off and return the ifi, if any
3310 if (result[0] == 0x1b && result[1] == 0x00) {
3311 memmove(&ifi,result+2,2);
3312 strcpy(result,result+4);
3314 return ifi; /* this is the RMS internal file id */
3317 static void pipe_infromchild_ast(pPipe p);
3320 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3321 inside an AST routine without worrying about reentrancy and which Perl
3322 memory allocator is being used.
3324 We read data and queue up the buffers, then spit them out one at a
3325 time to the output mailbox when the output mailbox is ready for one.
3328 #define INITIAL_TOCHILDQUEUE 2
3331 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3335 char mbx1[64], mbx2[64];
3336 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3337 DSC$K_CLASS_S, mbx1},
3338 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3339 DSC$K_CLASS_S, mbx2};
3340 unsigned int dviitm = DVI$_DEVBUFSIZ;
3344 _ckvmssts_noperl(lib$get_vm(&n, &p));
3346 create_mbx(&p->chan_in , &d_mbx1);
3347 create_mbx(&p->chan_out, &d_mbx2);
3348 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3351 p->shut_on_empty = FALSE;
3352 p->need_wake = FALSE;
3355 p->iosb.status = SS$_NORMAL;
3356 p->iosb2.status = SS$_NORMAL;
3362 #ifdef PERL_IMPLICIT_CONTEXT
3366 n = sizeof(CBuf) + p->bufsize;
3368 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3369 _ckvmssts_noperl(lib$get_vm(&n, &b));
3370 b->buf = (char *) b + sizeof(CBuf);
3371 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3374 pipe_tochild2_ast(p);
3375 pipe_tochild1_ast(p);
3381 /* reads the MBX Perl is writing, and queues */
3384 pipe_tochild1_ast(pPipe p)
3387 int iss = p->iosb.status;
3388 int eof = (iss == SS$_ENDOFFILE);
3390 #ifdef PERL_IMPLICIT_CONTEXT
3396 p->shut_on_empty = TRUE;
3398 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3400 _ckvmssts_noperl(iss);
3404 b->size = p->iosb.count;
3405 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3407 p->need_wake = FALSE;
3408 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3411 p->retry = 1; /* initial call */
3414 if (eof) { /* flush the free queue, return when done */
3415 int n = sizeof(CBuf) + p->bufsize;
3417 iss = lib$remqti(&p->free, &b);
3418 if (iss == LIB$_QUEWASEMP) return;
3419 _ckvmssts_noperl(iss);
3420 _ckvmssts_noperl(lib$free_vm(&n, &b));
3424 iss = lib$remqti(&p->free, &b);
3425 if (iss == LIB$_QUEWASEMP) {
3426 int n = sizeof(CBuf) + p->bufsize;
3427 _ckvmssts_noperl(lib$get_vm(&n, &b));
3428 b->buf = (char *) b + sizeof(CBuf);
3430 _ckvmssts_noperl(iss);
3434 iss = sys$qio(0,p->chan_in,
3435 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3437 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3438 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3439 _ckvmssts_noperl(iss);
3443 /* writes queued buffers to output, waits for each to complete before
3447 pipe_tochild2_ast(pPipe p)
3450 int iss = p->iosb2.status;
3451 int n = sizeof(CBuf) + p->bufsize;
3452 int done = (p->info && p->info->done) ||
3453 iss == SS$_CANCEL || iss == SS$_ABORT;
3454 #if defined(PERL_IMPLICIT_CONTEXT)
3459 if (p->type) { /* type=1 has old buffer, dispose */
3460 if (p->shut_on_empty) {
3461 _ckvmssts_noperl(lib$free_vm(&n, &b));
3463 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3468 iss = lib$remqti(&p->wait, &b);
3469 if (iss == LIB$_QUEWASEMP) {
3470 if (p->shut_on_empty) {
3472 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3473 *p->pipe_done = TRUE;
3474 _ckvmssts_noperl(sys$setef(pipe_ef));
3476 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3477 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3481 p->need_wake = TRUE;
3484 _ckvmssts_noperl(iss);
3491 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3492 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3494 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3495 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3504 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3507 char mbx1[64], mbx2[64];
3508 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3509 DSC$K_CLASS_S, mbx1},
3510 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3511 DSC$K_CLASS_S, mbx2};
3512 unsigned int dviitm = DVI$_DEVBUFSIZ;
3514 int n = sizeof(Pipe);
3515 _ckvmssts_noperl(lib$get_vm(&n, &p));
3516 create_mbx(&p->chan_in , &d_mbx1);
3517 create_mbx(&p->chan_out, &d_mbx2);
3519 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3520 n = p->bufsize * sizeof(char);
3521 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3522 p->shut_on_empty = FALSE;
3525 p->iosb.status = SS$_NORMAL;
3526 #if defined(PERL_IMPLICIT_CONTEXT)
3529 pipe_infromchild_ast(p);
3537 pipe_infromchild_ast(pPipe p)
3539 int iss = p->iosb.status;
3540 int eof = (iss == SS$_ENDOFFILE);
3541 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3542 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3543 #if defined(PERL_IMPLICIT_CONTEXT)
3547 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3548 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3553 input shutdown if EOF from self (done or shut_on_empty)
3554 output shutdown if closing flag set (my_pclose)
3555 send data/eof from child or eof from self
3556 otherwise, re-read (snarf of data from child)
3561 if (myeof && p->chan_in) { /* input shutdown */
3562 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3567 if (myeof || kideof) { /* pass EOF to parent */
3568 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3569 pipe_infromchild_ast, p,
3572 } else if (eof) { /* eat EOF --- fall through to read*/
3574 } else { /* transmit data */
3575 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3576 pipe_infromchild_ast,p,
3577 p->buf, p->iosb.count, 0, 0, 0, 0));
3583 /* everything shut? flag as done */
3585 if (!p->chan_in && !p->chan_out) {
3586 *p->pipe_done = TRUE;
3587 _ckvmssts_noperl(sys$setef(pipe_ef));
3591 /* write completed (or read, if snarfing from child)
3592 if still have input active,
3593 queue read...immediate mode if shut_on_empty so we get EOF if empty
3595 check if Perl reading, generate EOFs as needed
3601 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3602 pipe_infromchild_ast,p,
3603 p->buf, p->bufsize, 0, 0, 0, 0);
3604 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3605 _ckvmssts_noperl(iss);
3606 } else { /* send EOFs for extra reads */
3607 p->iosb.status = SS$_ENDOFFILE;
3608 p->iosb.dvispec = 0;
3609 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3611 pipe_infromchild_ast, p, 0, 0, 0, 0));
3617 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3621 unsigned long dviitm = DVI$_DEVBUFSIZ;
3623 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3624 DSC$K_CLASS_S, mbx};
3625 int n = sizeof(Pipe);
3627 /* things like terminals and mbx's don't need this filter */
3628 if (fd && fstat(fd,&s) == 0) {
3629 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3631 unsigned short dev_len;
3632 struct dsc$descriptor_s d_dev;
3634 struct item_list_3 items[3];
3636 unsigned short dvi_iosb[4];
3638 cptr = getname(fd, out, 1);
3639 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3640 d_dev.dsc$a_pointer = out;
3641 d_dev.dsc$w_length = strlen(out);
3642 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3643 d_dev.dsc$b_class = DSC$K_CLASS_S;
3646 items[0].code = DVI$_DEVCHAR;
3647 items[0].bufadr = &devchar;
3648 items[0].retadr = NULL;
3650 items[1].code = DVI$_FULLDEVNAM;
3651 items[1].bufadr = device;
3652 items[1].retadr = &dev_len;
3656 status = sys$getdviw
3657 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3658 _ckvmssts_noperl(status);
3659 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3660 device[dev_len] = 0;
3662 if (!(devchar & DEV$M_DIR)) {
3663 strcpy(out, device);
3669 _ckvmssts_noperl(lib$get_vm(&n, &p));
3670 p->fd_out = dup(fd);
3671 create_mbx(&p->chan_in, &d_mbx);
3672 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3673 n = (p->bufsize+1) * sizeof(char);
3674 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3675 p->shut_on_empty = FALSE;
3680 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3681 pipe_mbxtofd_ast, p,
3682 p->buf, p->bufsize, 0, 0, 0, 0));
3688 pipe_mbxtofd_ast(pPipe p)
3690 int iss = p->iosb.status;
3691 int done = p->info->done;
3693 int eof = (iss == SS$_ENDOFFILE);
3694 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3695 int err = !(iss&1) && !eof;
3696 #if defined(PERL_IMPLICIT_CONTEXT)
3700 if (done && myeof) { /* end piping */
3702 sys$dassgn(p->chan_in);
3703 *p->pipe_done = TRUE;
3704 _ckvmssts_noperl(sys$setef(pipe_ef));
3708 if (!err && !eof) { /* good data to send to file */
3709 p->buf[p->iosb.count] = '\n';
3710 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3713 if (p->retry < MAX_RETRY) {
3714 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3720 _ckvmssts_noperl(iss);
3724 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3725 pipe_mbxtofd_ast, p,
3726 p->buf, p->bufsize, 0, 0, 0, 0);
3727 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3728 _ckvmssts_noperl(iss);
3732 typedef struct _pipeloc PLOC;
3733 typedef struct _pipeloc* pPLOC;
3737 char dir[NAM$C_MAXRSS+1];
3739 static pPLOC head_PLOC = 0;
3742 free_pipelocs(pTHX_ void *head)
3745 pPLOC *pHead = (pPLOC *)head;
3757 store_pipelocs(pTHX)
3766 char temp[NAM$C_MAXRSS+1];
3770 free_pipelocs(aTHX_ &head_PLOC);
3772 /* the . directory from @INC comes last */
3774 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3775 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3776 p->next = head_PLOC;
3778 strcpy(p->dir,"./");
3780 /* get the directory from $^X */
3782 unixdir = PerlMem_malloc(VMS_MAXRSS);
3783 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3785 #ifdef PERL_IMPLICIT_CONTEXT
3786 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3788 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3790 strcpy(temp, PL_origargv[0]);
3791 x = strrchr(temp,']');
3793 x = strrchr(temp,'>');
3795 /* It could be a UNIX path */
3796 x = strrchr(temp,'/');
3802 /* Got a bare name, so use default directory */
3807 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3808 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3809 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3810 p->next = head_PLOC;
3812 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3813 p->dir[NAM$C_MAXRSS] = '\0';
3817 /* reverse order of @INC entries, skip "." since entered above */
3819 #ifdef PERL_IMPLICIT_CONTEXT
3822 if (PL_incgv) av = GvAVn(PL_incgv);
3824 for (i = 0; av && i <= AvFILL(av); i++) {
3825 dirsv = *av_fetch(av,i,TRUE);
3827 if (SvROK(dirsv)) continue;
3828 dir = SvPVx(dirsv,n_a);
3829 if (strcmp(dir,".") == 0) continue;
3830 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3833 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3834 p->next = head_PLOC;
3836 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3837 p->dir[NAM$C_MAXRSS] = '\0';
3840 /* most likely spot (ARCHLIB) put first in the list */
3843 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3844 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3845 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3846 p->next = head_PLOC;
3848 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3849 p->dir[NAM$C_MAXRSS] = '\0';
3852 PerlMem_free(unixdir);
3856 Perl_cando_by_name_int
3857 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3858 #if !defined(PERL_IMPLICIT_CONTEXT)
3859 #define cando_by_name_int Perl_cando_by_name_int
3861 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3867 static int vmspipe_file_status = 0;
3868 static char vmspipe_file[NAM$C_MAXRSS+1];
3870 /* already found? Check and use ... need read+execute permission */
3872 if (vmspipe_file_status == 1) {
3873 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3874 && cando_by_name_int
3875 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3876 return vmspipe_file;
3878 vmspipe_file_status = 0;
3881 /* scan through stored @INC, $^X */
3883 if (vmspipe_file_status == 0) {
3884 char file[NAM$C_MAXRSS+1];
3885 pPLOC p = head_PLOC;
3890 strcpy(file, p->dir);
3891 dirlen = strlen(file);
3892 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3893 file[NAM$C_MAXRSS] = '\0';
3896 exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3897 if (!exp_res) continue;
3899 if (cando_by_name_int
3900 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3901 && cando_by_name_int
3902 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3903 vmspipe_file_status = 1;
3904 return vmspipe_file;
3907 vmspipe_file_status = -1; /* failed, use tempfiles */
3914 vmspipe_tempfile(pTHX)
3916 char file[NAM$C_MAXRSS+1];
3918 static int index = 0;
3922 /* create a tempfile */
3924 /* we can't go from W, shr=get to R, shr=get without
3925 an intermediate vulnerable state, so don't bother trying...
3927 and lib$spawn doesn't shr=put, so have to close the write
3929 So... match up the creation date/time and the FID to
3930 make sure we're dealing with the same file
3935 if (!decc_filename_unix_only) {
3936 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3937 fp = fopen(file,"w");
3939 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3940 fp = fopen(file,"w");
3942 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3943 fp = fopen(file,"w");
3948 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3949 fp = fopen(file,"w");
3951 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3952 fp = fopen(file,"w");
3954 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3955 fp = fopen(file,"w");
3959 if (!fp) return 0; /* we're hosed */
3961 fprintf(fp,"$! 'f$verify(0)'\n");
3962 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3963 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3964 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3965 fprintf(fp,"$ perl_on = \"set noon\"\n");
3966 fprintf(fp,"$ perl_exit = \"exit\"\n");
3967 fprintf(fp,"$ perl_del = \"delete\"\n");
3968 fprintf(fp,"$ pif = \"if\"\n");
3969 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3970 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3971 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3972 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3973 fprintf(fp,"$! --- build command line to get max possible length\n");
3974 fprintf(fp,"$c=perl_popen_cmd0\n");
3975 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3976 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3977 fprintf(fp,"$x=perl_popen_cmd3\n");
3978 fprintf(fp,"$c=c+x\n");
3979 fprintf(fp,"$ perl_on\n");
3980 fprintf(fp,"$ 'c'\n");
3981 fprintf(fp,"$ perl_status = $STATUS\n");
3982 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3983 fprintf(fp,"$ perl_exit 'perl_status'\n");
3986 fgetname(fp, file, 1);
3987 fstat(fileno(fp), &s0.crtl_stat);
3990 if (decc_filename_unix_only)
3991 int_tounixspec(file, file, NULL);
3992 fp = fopen(file,"r","shr=get");
3994 fstat(fileno(fp), &s1.crtl_stat);
3996 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3997 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
4006 static int vms_is_syscommand_xterm(void)
4008 const static struct dsc$descriptor_s syscommand_dsc =
4009 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
4011 const static struct dsc$descriptor_s decwdisplay_dsc =
4012 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
4014 struct item_list_3 items[2];
4015 unsigned short dvi_iosb[4];
4016 unsigned long devchar;
4017 unsigned long devclass;
4020 /* Very simple check to guess if sys$command is a decterm? */
4021 /* First see if the DECW$DISPLAY: device exists */
4023 items[0].code = DVI$_DEVCHAR;
4024 items[0].bufadr = &devchar;
4025 items[0].retadr = NULL;
4029 status = sys$getdviw
4030 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
4032 if ($VMS_STATUS_SUCCESS(status)) {
4033 status = dvi_iosb[0];
4036 if (!$VMS_STATUS_SUCCESS(status)) {
4037 SETERRNO(EVMSERR, status);
4041 /* If it does, then for now assume that we are on a workstation */
4042 /* Now verify that SYS$COMMAND is a terminal */
4043 /* for creating the debugger DECTerm */
4046 items[0].code = DVI$_DEVCLASS;
4047 items[0].bufadr = &devclass;
4048 items[0].retadr = NULL;
4052 status = sys$getdviw
4053 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
4055 if ($VMS_STATUS_SUCCESS(status)) {
4056 status = dvi_iosb[0];
4059 if (!$VMS_STATUS_SUCCESS(status)) {
4060 SETERRNO(EVMSERR, status);
4064 if (devclass == DC$_TERM) {
4071 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
4072 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
4077 char device_name[65];
4078 unsigned short device_name_len;
4079 struct dsc$descriptor_s customization_dsc;
4080 struct dsc$descriptor_s device_name_dsc;
4083 char customization[200];
4087 unsigned short p_chan;
4089 unsigned short iosb[4];
4090 struct item_list_3 items[2];
4091 const char * cust_str =
4092 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4093 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4094 DSC$K_CLASS_S, mbx1};
4096 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4097 /*---------------------------------------*/
4098 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4101 /* Make sure that this is from the Perl debugger */
4102 ret_char = strstr(cmd," xterm ");
4103 if (ret_char == NULL)
4105 cptr = ret_char + 7;
4106 ret_char = strstr(cmd,"tty");
4107 if (ret_char == NULL)
4109 ret_char = strstr(cmd,"sleep");
4110 if (ret_char == NULL)
4113 if (decw_term_port == 0) {
4114 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4115 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4116 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4118 status = lib$find_image_symbol
4120 &decw_term_port_dsc,
4121 (void *)&decw_term_port,
4125 /* Try again with the other image name */
4126 if (!$VMS_STATUS_SUCCESS(status)) {
4128 status = lib$find_image_symbol
4130 &decw_term_port_dsc,
4131 (void *)&decw_term_port,
4140 /* No decw$term_port, give it up */
4141 if (!$VMS_STATUS_SUCCESS(status))
4144 /* Are we on a workstation? */
4145 /* to do: capture the rows / columns and pass their properties */
4146 ret_stat = vms_is_syscommand_xterm();
4150 /* Make the title: */
4151 ret_char = strstr(cptr,"-title");
4152 if (ret_char != NULL) {
4153 while ((*cptr != 0) && (*cptr != '\"')) {
4159 while ((*cptr != 0) && (*cptr != '\"')) {
4172 strcpy(title,"Perl Debug DECTerm");
4174 sprintf(customization, cust_str, title);
4176 customization_dsc.dsc$a_pointer = customization;
4177 customization_dsc.dsc$w_length = strlen(customization);
4178 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4179 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4181 device_name_dsc.dsc$a_pointer = device_name;
4182 device_name_dsc.dsc$w_length = sizeof device_name -1;
4183 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4184 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4186 device_name_len = 0;
4188 /* Try to create the window */
4189 status = (*decw_term_port)
4198 if (!$VMS_STATUS_SUCCESS(status)) {
4199 SETERRNO(EVMSERR, status);
4203 device_name[device_name_len] = '\0';
4205 /* Need to set this up to look like a pipe for cleanup */
4207 status = lib$get_vm(&n, &info);
4208 if (!$VMS_STATUS_SUCCESS(status)) {
4209 SETERRNO(ENOMEM, status);
4215 info->completion = 0;
4216 info->closing = FALSE;
4223 info->in_done = TRUE;
4224 info->out_done = TRUE;
4225 info->err_done = TRUE;
4227 /* Assign a channel on this so that it will persist, and not login */
4228 /* We stash this channel in the info structure for reference. */
4229 /* The created xterm self destructs when the last channel is removed */
4230 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4231 /* So leave this assigned. */
4232 device_name_dsc.dsc$w_length = device_name_len;
4233 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4234 if (!$VMS_STATUS_SUCCESS(status)) {
4235 SETERRNO(EVMSERR, status);
4238 info->xchan_valid = 1;
4240 /* Now create a mailbox to be read by the application */
4242 create_mbx(&p_chan, &d_mbx1);
4244 /* write the name of the created terminal to the mailbox */
4245 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4246 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4248 if (!$VMS_STATUS_SUCCESS(status)) {
4249 SETERRNO(EVMSERR, status);
4253 info->fp = PerlIO_open(mbx1, mode);
4255 /* Done with this channel */
4258 /* If any errors, then clean up */
4261 _ckvmssts_noperl(lib$free_vm(&n, &info));
4269 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4272 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4274 static int handler_set_up = FALSE;
4276 unsigned long int sts, flags = CLI$M_NOWAIT;
4277 /* The use of a GLOBAL table (as was done previously) rendered
4278 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4279 * environment. Hence we've switched to LOCAL symbol table.
4281 unsigned int table = LIB$K_CLI_LOCAL_SYM;
4283 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4284 char *in, *out, *err, mbx[512];
4286 char tfilebuf[NAM$C_MAXRSS+1];
4288 char cmd_sym_name[20];
4289 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4290 DSC$K_CLASS_S, symbol};
4291 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4293 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4294 DSC$K_CLASS_S, cmd_sym_name};
4295 struct dsc$descriptor_s *vmscmd;
4296 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4297 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4298 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4300 /* Check here for Xterm create request. This means looking for
4301 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4302 * is possible to create an xterm.
4304 if (*in_mode == 'r') {
4307 #if defined(PERL_IMPLICIT_CONTEXT)
4308 /* Can not fork an xterm with a NULL context */
4309 /* This probably could never happen */
4313 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4314 if (xterm_fd != NULL)
4318 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4320 /* once-per-program initialization...
4321 note that the SETAST calls and the dual test of pipe_ef
4322 makes sure that only the FIRST thread through here does
4323 the initialization...all other threads wait until it's
4326 Yeah, uglier than a pthread call, it's got all the stuff inline
4327 rather than in a separate routine.
4331 _ckvmssts_noperl(sys$setast(0));
4333 unsigned long int pidcode = JPI$_PID;
4334 $DESCRIPTOR(d_delay, RETRY_DELAY);
4335 _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4336 _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4337 _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4339 if (!handler_set_up) {
4340 _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4341 handler_set_up = TRUE;
4343 _ckvmssts_noperl(sys$setast(1));
4346 /* see if we can find a VMSPIPE.COM */
4349 vmspipe = find_vmspipe(aTHX);
4351 strcpy(tfilebuf+1,vmspipe);
4352 } else { /* uh, oh...we're in tempfile hell */
4353 tpipe = vmspipe_tempfile(aTHX);
4354 if (!tpipe) { /* a fish popular in Boston */
4355 if (ckWARN(WARN_PIPE)) {
4356 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4360 fgetname(tpipe,tfilebuf+1,1);
4362 vmspipedsc.dsc$a_pointer = tfilebuf;
4363 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4365 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4368 case RMS$_FNF: case RMS$_DNF:
4369 set_errno(ENOENT); break;
4371 set_errno(ENOTDIR); break;
4373 set_errno(ENODEV); break;
4375 set_errno(EACCES); break;
4377 set_errno(EINVAL); break;
4378 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4379 set_errno(E2BIG); break;
4380 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4381 _ckvmssts_noperl(sts); /* fall through */
4382 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4385 set_vaxc_errno(sts);
4386 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4387 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4393 _ckvmssts_noperl(lib$get_vm(&n, &info));
4395 strcpy(mode,in_mode);
4398 info->completion = 0;
4399 info->closing = FALSE;
4406 info->in_done = TRUE;
4407 info->out_done = TRUE;
4408 info->err_done = TRUE;
4410 info->xchan_valid = 0;
4412 in = PerlMem_malloc(VMS_MAXRSS);
4413 if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4414 out = PerlMem_malloc(VMS_MAXRSS);
4415 if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4416 err = PerlMem_malloc(VMS_MAXRSS);
4417 if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4419 in[0] = out[0] = err[0] = '\0';
4421 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4425 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4430 if (*mode == 'r') { /* piping from subroutine */
4432 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4434 info->out->pipe_done = &info->out_done;
4435 info->out_done = FALSE;
4436 info->out->info = info;
4438 if (!info->useFILE) {
4439 info->fp = PerlIO_open(mbx, mode);
4441 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4442 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4445 if (!info->fp && info->out) {
4446 sys$cancel(info->out->chan_out);
4448 while (!info->out_done) {
4450 _ckvmssts_noperl(sys$setast(0));
4451 done = info->out_done;
4452 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4453 _ckvmssts_noperl(sys$setast(1));
4454 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4457 if (info->out->buf) {
4458 n = info->out->bufsize * sizeof(char);
4459 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4462 _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4464 _ckvmssts_noperl(lib$free_vm(&n, &info));
4469 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4471 info->err->pipe_done = &info->err_done;
4472 info->err_done = FALSE;
4473 info->err->info = info;
4476 } else if (*mode == 'w') { /* piping to subroutine */
4478 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4480 info->out->pipe_done = &info->out_done;
4481 info->out_done = FALSE;
4482 info->out->info = info;
4485 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4487 info->err->pipe_done = &info->err_done;
4488 info->err_done = FALSE;
4489 info->err->info = info;
4492 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4493 if (!info->useFILE) {
4494 info->fp = PerlIO_open(mbx, mode);
4496 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4497 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4501 info->in->pipe_done = &info->in_done;
4502 info->in_done = FALSE;
4503 info->in->info = info;
4507 if (!info->fp && info->in) {
4509 _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4510 0, 0, 0, 0, 0, 0, 0, 0));
4512 while (!info->in_done) {
4514 _ckvmssts_noperl(sys$setast(0));
4515 done = info->in_done;
4516 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4517 _ckvmssts_noperl(sys$setast(1));
4518 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4521 if (info->in->buf) {
4522 n = info->in->bufsize * sizeof(char);
4523 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4526 _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4528 _ckvmssts_noperl(lib$free_vm(&n, &info));
4534 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4535 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4537 info->out->pipe_done = &info->out_done;
4538 info->out_done = FALSE;
4539 info->out->info = info;
4542 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4544 info->err->pipe_done = &info->err_done;
4545 info->err_done = FALSE;
4546 info->err->info = info;
4550 symbol[MAX_DCL_SYMBOL] = '\0';
4552 strncpy(symbol, in, MAX_DCL_SYMBOL);
4553 d_symbol.dsc$w_length = strlen(symbol);
4554 _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4556 strncpy(symbol, err, MAX_DCL_SYMBOL);
4557 d_symbol.dsc$w_length = strlen(symbol);
4558 _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4560 strncpy(symbol, out, MAX_DCL_SYMBOL);
4561 d_symbol.dsc$w_length = strlen(symbol);
4562 _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4564 /* Done with the names for the pipes */
4569 p = vmscmd->dsc$a_pointer;
4570 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4571 if (*p == '$') p++; /* remove leading $ */
4572 while (*p == ' ' || *p == '\t') p++;
4574 for (j = 0; j < 4; j++) {
4575 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4576 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4578 strncpy(symbol, p, MAX_DCL_SYMBOL);
4579 d_symbol.dsc$w_length = strlen(symbol);
4580 _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4582 if (strlen(p) > MAX_DCL_SYMBOL) {
4583 p += MAX_DCL_SYMBOL;
4588 _ckvmssts_noperl(sys$setast(0));
4589 info->next=open_pipes; /* prepend to list */
4591 _ckvmssts_noperl(sys$setast(1));
4592 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4593 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4594 * have SYS$COMMAND if we need it.
4596 _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4597 0, &info->pid, &info->completion,
4598 0, popen_completion_ast,info,0,0,0));
4600 /* if we were using a tempfile, close it now */
4602 if (tpipe) fclose(tpipe);
4604 /* once the subprocess is spawned, it has copied the symbols and
4605 we can get rid of ours */
4607 for (j = 0; j < 4; j++) {
4608 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4609 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4610 _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4612 _ckvmssts_noperl(lib$delete_symbol(&d_sym_in, &table));
4613 _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4614 _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4615 vms_execfree(vmscmd);
4617 #ifdef PERL_IMPLICIT_CONTEXT
4620 PL_forkprocess = info->pid;
4627 _ckvmssts_noperl(sys$setast(0));
4629 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4630 _ckvmssts_noperl(sys$setast(1));
4631 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4633 *psts = info->completion;
4634 /* Caller thinks it is open and tries to close it. */
4635 /* This causes some problems, as it changes the error status */
4636 /* my_pclose(info->fp); */
4638 /* If we did not have a file pointer open, then we have to */
4639 /* clean up here or eventually we will run out of something */
4641 if (info->fp == NULL) {
4642 my_pclose_pinfo(aTHX_ info);
4650 } /* end of safe_popen */
4653 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4655 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4659 TAINT_PROPER("popen");
4660 PERL_FLUSHALL_FOR_CHILD;
4661 return safe_popen(aTHX_ cmd,mode,&sts);
4667 /* Routine to close and cleanup a pipe info structure */
4669 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4671 unsigned long int retsts;
4676 /* If we were writing to a subprocess, insure that someone reading from
4677 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4678 * produce an EOF record in the mailbox.
4680 * well, at least sometimes it *does*, so we have to watch out for
4681 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4685 #if defined(USE_ITHREADS)
4688 && PL_perlio_fd_refcnt)
4689 PerlIO_flush(info->fp);
4691 fflush((FILE *)info->fp);
4694 _ckvmssts(sys$setast(0));
4695 info->closing = TRUE;
4696 done = info->done && info->in_done && info->out_done && info->err_done;
4697 /* hanging on write to Perl's input? cancel it */
4698 if (info->mode == 'r' && info->out && !info->out_done) {
4699 if (info->out->chan_out) {
4700 _ckvmssts(sys$cancel(info->out->chan_out));
4701 if (!info->out->chan_in) { /* EOF generation, need AST */
4702 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4706 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4707 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4709 _ckvmssts(sys$setast(1));
4712 #if defined(USE_ITHREADS)
4715 && PL_perlio_fd_refcnt)
4716 PerlIO_close(info->fp);
4718 fclose((FILE *)info->fp);
4721 we have to wait until subprocess completes, but ALSO wait until all
4722 the i/o completes...otherwise we'll be freeing the "info" structure
4723 that the i/o ASTs could still be using...
4727 _ckvmssts(sys$setast(0));
4728 done = info->done && info->in_done && info->out_done && info->err_done;
4729 if (!done) _ckvmssts(sys$clref(pipe_ef));
4730 _ckvmssts(sys$setast(1));
4731 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4733 retsts = info->completion;
4735 /* remove from list of open pipes */
4736 _ckvmssts(sys$setast(0));
4738 for (next = open_pipes; next != NULL; last = next, next = next->next) {
4744 last->next = info->next;
4746 open_pipes = info->next;
4747 _ckvmssts(sys$setast(1));
4749 /* free buffers and structures */
4752 if (info->in->buf) {
4753 n = info->in->bufsize * sizeof(char);
4754 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4757 _ckvmssts(lib$free_vm(&n, &info->in));
4760 if (info->out->buf) {
4761 n = info->out->bufsize * sizeof(char);
4762 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4765 _ckvmssts(lib$free_vm(&n, &info->out));
4768 if (info->err->buf) {
4769 n = info->err->bufsize * sizeof(char);
4770 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4773 _ckvmssts(lib$free_vm(&n, &info->err));
4776 _ckvmssts(lib$free_vm(&n, &info));
4782 /*{{{ I32 my_pclose(PerlIO *fp)*/
4783 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4785 pInfo info, last = NULL;
4788 /* Fixme - need ast and mutex protection here */
4789 for (info = open_pipes; info != NULL; last = info, info = info->next)
4790 if (info->fp == fp) break;
4792 if (info == NULL) { /* no such pipe open */
4793 set_errno(ECHILD); /* quoth POSIX */
4794 set_vaxc_errno(SS$_NONEXPR);
4798 ret_status = my_pclose_pinfo(aTHX_ info);
4802 } /* end of my_pclose() */
4804 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4805 /* Roll our own prototype because we want this regardless of whether
4806 * _VMS_WAIT is defined.
4808 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4810 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4811 created with popen(); otherwise partially emulate waitpid() unless
4812 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4813 Also check processes not considered by the CRTL waitpid().
4815 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4817 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4824 if (statusp) *statusp = 0;
4826 for (info = open_pipes; info != NULL; info = info->next)
4827 if (info->pid == pid) break;
4829 if (info != NULL) { /* we know about this child */
4830 while (!info->done) {
4831 _ckvmssts(sys$setast(0));
4833 if (!done) _ckvmssts(sys$clref(pipe_ef));
4834 _ckvmssts(sys$setast(1));
4835 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4838 if (statusp) *statusp = info->completion;
4842 /* child that already terminated? */
4844 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4845 if (closed_list[j].pid == pid) {
4846 if (statusp) *statusp = closed_list[j].completion;
4851 /* fall through if this child is not one of our own pipe children */
4853 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4855 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4856 * in 7.2 did we get a version that fills in the VMS completion
4857 * status as Perl has always tried to do.
4860 sts = __vms_waitpid( pid, statusp, flags );
4862 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4865 /* If the real waitpid tells us the child does not exist, we
4866 * fall through here to implement waiting for a child that
4867 * was created by some means other than exec() (say, spawned
4868 * from DCL) or to wait for a process that is not a subprocess
4869 * of the current process.
4872 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4875 $DESCRIPTOR(intdsc,"0 00:00:01");
4876 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4877 unsigned long int pidcode = JPI$_PID, mypid;
4878 unsigned long int interval[2];
4879 unsigned int jpi_iosb[2];
4880 struct itmlst_3 jpilist[2] = {
4881 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4886 /* Sorry folks, we don't presently implement rooting around for
4887 the first child we can find, and we definitely don't want to
4888 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4894 /* Get the owner of the child so I can warn if it's not mine. If the
4895 * process doesn't exist or I don't have the privs to look at it,
4896 * I can go home early.
4898 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4899 if (sts & 1) sts = jpi_iosb[0];
4911 set_vaxc_errno(sts);
4915 if (ckWARN(WARN_EXEC)) {
4916 /* remind folks they are asking for non-standard waitpid behavior */
4917 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4918 if (ownerpid != mypid)
4919 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4920 "waitpid: process %x is not a child of process %x",
4924 /* simply check on it once a second until it's not there anymore. */
4926 _ckvmssts(sys$bintim(&intdsc,interval));
4927 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4928 _ckvmssts(sys$schdwk(0,0,interval,0));
4929 _ckvmssts(sys$hiber());
4931 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4936 } /* end of waitpid() */
4941 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4943 my_gconvert(double val, int ndig, int trail, char *buf)
4945 static char __gcvtbuf[DBL_DIG+1];
4948 loc = buf ? buf : __gcvtbuf;
4950 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4952 sprintf(loc,"%.*g",ndig,val);
4958 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4959 return gcvt(val,ndig,loc);
4962 loc[0] = '0'; loc[1] = '\0';
4969 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4970 static int rms_free_search_context(struct FAB * fab)
4974 nam = fab->fab$l_nam;
4975 nam->nam$b_nop |= NAM$M_SYNCHK;
4976 nam->nam$l_rlf = NULL;
4978 return sys$parse(fab, NULL, NULL);
4981 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4982 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4983 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4984 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4985 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4986 #define rms_nam_esll(nam) nam.nam$b_esl
4987 #define rms_nam_esl(nam) nam.nam$b_esl
4988 #define rms_nam_name(nam) nam.nam$l_name
4989 #define rms_nam_namel(nam) nam.nam$l_name
4990 #define rms_nam_type(nam) nam.nam$l_type
4991 #define rms_nam_typel(nam) nam.nam$l_type
4992 #define rms_nam_ver(nam) nam.nam$l_ver
4993 #define rms_nam_verl(nam) nam.nam$l_ver
4994 #define rms_nam_rsll(nam) nam.nam$b_rsl
4995 #define rms_nam_rsl(nam) nam.nam$b_rsl
4996 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4997 #define rms_set_fna(fab, nam, name, size) \
4998 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4999 #define rms_get_fna(fab, nam) fab.fab$l_fna
5000 #define rms_set_dna(fab, nam, name, size) \
5001 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
5002 #define rms_nam_dns(fab, nam) fab.fab$b_dns
5003 #define rms_set_esa(nam, name, size) \
5004 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
5005 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5006 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
5007 #define rms_set_rsa(nam, name, size) \
5008 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
5009 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5010 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
5011 #define rms_nam_name_type_l_size(nam) \
5012 (nam.nam$b_name + nam.nam$b_type)
5014 static int rms_free_search_context(struct FAB * fab)
5018 nam = fab->fab$l_naml;
5019 nam->naml$b_nop |= NAM$M_SYNCHK;
5020 nam->naml$l_rlf = NULL;
5021 nam->naml$l_long_defname_size = 0;
5024 return sys$parse(fab, NULL, NULL);
5027 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
5028 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
5029 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
5030 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
5031 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
5032 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
5033 #define rms_nam_esl(nam) nam.naml$b_esl
5034 #define rms_nam_name(nam) nam.naml$l_name
5035 #define rms_nam_namel(nam) nam.naml$l_long_name
5036 #define rms_nam_type(nam) nam.naml$l_type
5037 #define rms_nam_typel(nam) nam.naml$l_long_type
5038 #define rms_nam_ver(nam) nam.naml$l_ver
5039 #define rms_nam_verl(nam) nam.naml$l_long_ver
5040 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
5041 #define rms_nam_rsl(nam) nam.naml$b_rsl
5042 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
5043 #define rms_set_fna(fab, nam, name, size) \
5044 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
5045 nam.naml$l_long_filename_size = size; \
5046 nam.naml$l_long_filename = name;}
5047 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
5048 #define rms_set_dna(fab, nam, name, size) \
5049 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
5050 nam.naml$l_long_defname_size = size; \
5051 nam.naml$l_long_defname = name; }
5052 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
5053 #define rms_set_esa(nam, name, size) \
5054 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
5055 nam.naml$l_long_expand_alloc = size; \
5056 nam.naml$l_long_expand = name; }
5057 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5058 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
5059 nam.naml$l_long_expand = l_name; \
5060 nam.naml$l_long_expand_alloc = l_size; }
5061 #define rms_set_rsa(nam, name, size) \
5062 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
5063 nam.naml$l_long_result = name; \
5064 nam.naml$l_long_result_alloc = size; }
5065 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5066 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
5067 nam.naml$l_long_result = l_name; \
5068 nam.naml$l_long_result_alloc = l_size; }
5069 #define rms_nam_name_type_l_size(nam) \
5070 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
5075 * The CRTL for 8.3 and later can create symbolic links in any mode,
5076 * however in 8.3 the unlink/remove/delete routines will only properly handle
5077 * them if one of the PCP modes is active.
5079 static int rms_erase(const char * vmsname)
5082 struct FAB myfab = cc$rms_fab;
5083 rms_setup_nam(mynam);
5085 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
5086 rms_bind_fab_nam(myfab, mynam);
5088 #ifdef NAML$M_OPEN_SPECIAL
5089 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5092 status = sys$erase(&myfab, 0, 0);
5099 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5100 const struct dsc$descriptor_s * vms_dst_dsc,
5101 unsigned long flags)
5103 /* VMS and UNIX handle file permissions differently and the
5104 * the same ACL trick may be needed for renaming files,
5105 * especially if they are directories.
5108 /* todo: get kill_file and rename to share common code */
5109 /* I can not find online documentation for $change_acl
5110 * it appears to be replaced by $set_security some time ago */
5112 const unsigned int access_mode = 0;
5113 $DESCRIPTOR(obj_file_dsc,"FILE");
5116 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5117 int aclsts, fndsts, rnsts = -1;
5118 unsigned int ctx = 0;
5119 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5120 struct dsc$descriptor_s * clean_dsc;
5123 unsigned char myace$b_length;
5124 unsigned char myace$b_type;
5125 unsigned short int myace$w_flags;
5126 unsigned long int myace$l_access;
5127 unsigned long int myace$l_ident;
5128 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5129 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5131 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5134 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5135 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5137 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5138 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5142 /* Expand the input spec using RMS, since we do not want to put
5143 * ACLs on the target of a symbolic link */
5144 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5145 if (vmsname == NULL)
5148 rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5150 PERL_RMSEXPAND_M_SYMLINK);
5152 PerlMem_free(vmsname);
5156 /* So we get our own UIC to use as a rights identifier,
5157 * and the insert an ACE at the head of the ACL which allows us
5158 * to delete the file.
5160 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5162 fildsc.dsc$w_length = strlen(vmsname);
5163 fildsc.dsc$a_pointer = vmsname;
5165 newace.myace$l_ident = oldace.myace$l_ident;
5168 /* Grab any existing ACEs with this identifier in case we fail */
5169 clean_dsc = &fildsc;
5170 aclsts = fndsts = sys$get_security(&obj_file_dsc,
5178 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
5179 /* Add the new ACE . . . */
5181 /* if the sys$get_security succeeded, then ctx is valid, and the
5182 * object/file descriptors will be ignored. But otherwise they
5185 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5186 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5187 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5189 set_vaxc_errno(aclsts);
5190 PerlMem_free(vmsname);
5194 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5197 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5199 if ($VMS_STATUS_SUCCESS(rnsts)) {
5200 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5203 /* Put things back the way they were. */
5205 aclsts = sys$get_security(&obj_file_dsc,
5213 if ($VMS_STATUS_SUCCESS(aclsts)) {
5217 if (!$VMS_STATUS_SUCCESS(fndsts))
5218 sec_flags = OSS$M_RELCTX;
5220 /* Get rid of the new ACE */
5221 aclsts = sys$set_security(NULL, NULL, NULL,
5222 sec_flags, dellst, &ctx, &access_mode);
5224 /* If there was an old ACE, put it back */
5225 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5226 addlst[0].bufadr = &oldace;
5227 aclsts = sys$set_security(NULL, NULL, NULL,
5228 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5229 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5231 set_vaxc_errno(aclsts);
5237 /* Try to clear the lock on the ACL list */
5238 aclsts2 = sys$set_security(NULL, NULL, NULL,
5239 OSS$M_RELCTX, NULL, &ctx, &access_mode);
5241 /* Rename errors are most important */
5242 if (!$VMS_STATUS_SUCCESS(rnsts))
5245 set_vaxc_errno(aclsts);
5250 if (aclsts != SS$_ACLEMPTY)
5257 PerlMem_free(vmsname);
5262 /*{{{int rename(const char *, const char * */
5263 /* Not exactly what X/Open says to do, but doing it absolutely right
5264 * and efficiently would require a lot more work. This should be close
5265 * enough to pass all but the most strict X/Open compliance test.
5268 Perl_rename(pTHX_ const char *src, const char * dst)
5277 /* Validate the source file */
5278 src_sts = flex_lstat(src, &src_st);
5281 /* No source file or other problem */
5284 if (src_st.st_devnam[0] == 0) {
5285 /* This may be possible so fail if it is seen. */
5290 dst_sts = flex_lstat(dst, &dst_st);
5293 if (dst_st.st_dev != src_st.st_dev) {
5294 /* Must be on the same device */
5299 /* VMS_INO_T_COMPARE is true if the inodes are different
5300 * to match the output of memcmp
5303 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5304 /* That was easy, the files are the same! */
5308 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5309 /* If source is a directory, so must be dest */
5317 if ((dst_sts == 0) &&
5318 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5320 /* We have issues here if vms_unlink_all_versions is set
5321 * If the destination exists, and is not a directory, then
5322 * we must delete in advance.
5324 * If the src is a directory, then we must always pre-delete
5327 * If we successfully delete the dst in advance, and the rename fails
5328 * X/Open requires that errno be EIO.
5332 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5334 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5335 S_ISDIR(dst_st.st_mode));
5337 /* Need to delete all versions ? */
5338 if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5341 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5342 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5347 /* Make sure that we do not loop forever */
5359 /* We killed the destination, so only errno now is EIO */
5364 /* Originally the idea was to call the CRTL rename() and only
5365 * try the lib$rename_file if it failed.
5366 * It turns out that there are too many variants in what the
5367 * the CRTL rename might do, so only use lib$rename_file
5372 /* Is the source and dest both in VMS format */
5373 /* if the source is a directory, then need to fileify */
5374 /* and dest must be a directory or non-existant. */
5379 unsigned long flags;
5380 struct dsc$descriptor_s old_file_dsc;
5381 struct dsc$descriptor_s new_file_dsc;
5383 /* We need to modify the src and dst depending
5384 * on if one or more of them are directories.
5387 vms_dst = PerlMem_malloc(VMS_MAXRSS);
5388 if (vms_dst == NULL)
5389 _ckvmssts_noperl(SS$_INSFMEM);
5391 if (S_ISDIR(src_st.st_mode)) {
5393 char * vms_dir_file;
5395 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5396 if (vms_dir_file == NULL)
5397 _ckvmssts_noperl(SS$_INSFMEM);
5399 /* If the dest is a directory, we must remove it
5402 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5404 PerlMem_free(vms_dst);
5412 /* The dest must be a VMS file specification */
5413 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5414 if (ret_str == NULL) {
5415 PerlMem_free(vms_dst);
5420 /* The source must be a file specification */
5421 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5422 if (vms_dir_file == NULL)
5423 _ckvmssts_noperl(SS$_INSFMEM);
5425 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5426 if (ret_str == NULL) {
5427 PerlMem_free(vms_dst);
5428 PerlMem_free(vms_dir_file);
5432 PerlMem_free(vms_dst);
5433 vms_dst = vms_dir_file;
5436 /* File to file or file to new dir */
5438 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5439 /* VMS pathify a dir target */
5440 ret_str = int_tovmspath(dst, vms_dst, NULL);
5441 if (ret_str == NULL) {
5442 PerlMem_free(vms_dst);
5447 char * v_spec, * r_spec, * d_spec, * n_spec;
5448 char * e_spec, * vs_spec;
5449 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5451 /* fileify a target VMS file specification */
5452 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5453 if (ret_str == NULL) {
5454 PerlMem_free(vms_dst);
5459 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5460 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5461 &e_len, &vs_spec, &vs_len);
5464 /* Get rid of the version */
5468 /* Need to specify a '.' so that the extension */
5469 /* is not inherited */
5470 strcat(vms_dst,".");
5476 old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5477 old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5478 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5479 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5481 new_file_dsc.dsc$a_pointer = vms_dst;
5482 new_file_dsc.dsc$w_length = strlen(vms_dst);
5483 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5484 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5487 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5488 flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5491 sts = lib$rename_file(&old_file_dsc,
5495 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5496 if (!$VMS_STATUS_SUCCESS(sts)) {
5498 /* We could have failed because VMS style permissions do not
5499 * permit renames that UNIX will allow. Just like the hack
5502 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5505 PerlMem_free(vms_dst);
5506 if (!$VMS_STATUS_SUCCESS(sts)) {
5513 if (vms_unlink_all_versions) {
5514 /* Now get rid of any previous versions of the source file that
5520 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5521 S_ISDIR(src_st.st_mode));
5522 while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5523 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5524 S_ISDIR(src_st.st_mode));
5529 /* Make sure that we do not loop forever */
5538 /* We deleted the destination, so must force the error to be EIO */
5539 if ((retval != 0) && (pre_delete != 0))
5547 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5548 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5549 * to expand file specification. Allows for a single default file
5550 * specification and a simple mask of options. If outbuf is non-NULL,
5551 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5552 * the resultant file specification is placed. If outbuf is NULL, the
5553 * resultant file specification is placed into a static buffer.
5554 * The third argument, if non-NULL, is taken to be a default file
5555 * specification string. The fourth argument is unused at present.
5556 * rmesexpand() returns the address of the resultant string if
5557 * successful, and NULL on error.
5559 * New functionality for previously unused opts value:
5560 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5561 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5562 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5563 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5565 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5569 (const char *filespec,
5571 const char *defspec,
5577 const char * in_spec;
5579 const char * def_spec;
5580 char * vmsfspec, *vmsdefspec;
5584 struct FAB myfab = cc$rms_fab;
5585 rms_setup_nam(mynam);
5587 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5590 /* temp hack until UTF8 is actually implemented */
5591 if (fs_utf8 != NULL)
5594 if (!filespec || !*filespec) {
5595 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5605 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5606 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5607 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5609 /* If this is a UNIX file spec, convert it to VMS */
5610 sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5611 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5612 &e_len, &vs_spec, &vs_len);
5617 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5618 if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5619 ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5620 if (ret_spec == NULL) {
5621 PerlMem_free(vmsfspec);
5624 in_spec = (const char *)vmsfspec;
5626 /* Unless we are forcing to VMS format, a UNIX input means
5627 * UNIX output, and that requires long names to be used
5629 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5630 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5631 opts |= PERL_RMSEXPAND_M_LONG;
5641 rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5642 rms_bind_fab_nam(myfab, mynam);
5644 /* Process the default file specification if present */
5646 if (defspec && *defspec) {
5648 t_isunix = is_unix_filespec(defspec);
5650 vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5651 if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5652 ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5654 if (ret_spec == NULL) {
5655 /* Clean up and bail */
5656 PerlMem_free(vmsdefspec);
5657 if (vmsfspec != NULL)
5658 PerlMem_free(vmsfspec);
5661 def_spec = (const char *)vmsdefspec;
5663 rms_set_dna(myfab, mynam,
5664 (char *)def_spec, strlen(def_spec)); /* cast ok */
5667 /* Now we need the expansion buffers */
5668 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5669 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5670 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5671 esal = PerlMem_malloc(VMS_MAXRSS);
5672 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5674 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5676 /* If a NAML block is used RMS always writes to the long and short
5677 * addresses unless you suppress the short name.
5679 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5680 outbufl = PerlMem_malloc(VMS_MAXRSS);
5681 if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5683 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5685 #ifdef NAM$M_NO_SHORT_UPCASE
5686 if (decc_efs_case_preserve)
5687 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5690 /* We may not want to follow symbolic links */
5691 #ifdef NAML$M_OPEN_SPECIAL
5692 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5693 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5696 /* First attempt to parse as an existing file */
5697 retsts = sys$parse(&myfab,0,0);
5698 if (!(retsts & STS$K_SUCCESS)) {
5700 /* Could not find the file, try as syntax only if error is not fatal */
5701 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5702 if (retsts == RMS$_DNF ||
5703 retsts == RMS$_DIR ||
5704 retsts == RMS$_DEV ||
5705 retsts == RMS$_PRV) {
5706 retsts = sys$parse(&myfab,0,0);
5707 if (retsts & STS$K_SUCCESS) goto int_expanded;
5710 /* Still could not parse the file specification */
5711 /*----------------------------------------------*/
5712 sts = rms_free_search_context(&myfab); /* Free search context */
5713 if (vmsdefspec != NULL)
5714 PerlMem_free(vmsdefspec);
5715 if (vmsfspec != NULL)
5716 PerlMem_free(vmsfspec);
5717 if (outbufl != NULL)
5718 PerlMem_free(outbufl);
5722 set_vaxc_errno(retsts);
5723 if (retsts == RMS$_PRV) set_errno(EACCES);
5724 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5725 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5726 else set_errno(EVMSERR);
5729 retsts = sys$search(&myfab,0,0);
5730 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5731 sts = rms_free_search_context(&myfab); /* Free search context */
5732 if (vmsdefspec != NULL)
5733 PerlMem_free(vmsdefspec);
5734 if (vmsfspec != NULL)
5735 PerlMem_free(vmsfspec);
5736 if (outbufl != NULL)
5737 PerlMem_free(outbufl);
5741 set_vaxc_errno(retsts);
5742 if (retsts == RMS$_PRV) set_errno(EACCES);
5743 else set_errno(EVMSERR);
5747 /* If the input filespec contained any lowercase characters,
5748 * downcase the result for compatibility with Unix-minded code. */
5750 if (!decc_efs_case_preserve) {
5752 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5753 if (islower(*tbuf)) { haslower = 1; break; }
5756 /* Is a long or a short name expected */
5757 /*------------------------------------*/
5759 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5760 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5761 if (rms_nam_rsll(mynam)) {
5763 speclen = rms_nam_rsll(mynam);
5766 spec_buf = esal; /* Not esa */
5767 speclen = rms_nam_esll(mynam);
5772 if (rms_nam_rsl(mynam)) {
5774 speclen = rms_nam_rsl(mynam);
5777 spec_buf = esa; /* Not esal */
5778 speclen = rms_nam_esl(mynam);
5780 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5783 spec_buf[speclen] = '\0';
5785 /* Trim off null fields added by $PARSE
5786 * If type > 1 char, must have been specified in original or default spec
5787 * (not true for version; $SEARCH may have added version of existing file).
5789 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5790 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5791 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5792 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5795 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5796 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5798 if (trimver || trimtype) {
5799 if (defspec && *defspec) {
5800 char *defesal = NULL;
5801 char *defesa = NULL;
5802 defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5803 if (defesa != NULL) {
5804 struct FAB deffab = cc$rms_fab;
5805 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5806 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5807 if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5809 rms_setup_nam(defnam);
5811 rms_bind_fab_nam(deffab, defnam);
5815 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5817 /* RMS needs the esa/esal as a work area if wildcards are involved */
5818 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5820 rms_clear_nam_nop(defnam);
5821 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5822 #ifdef NAM$M_NO_SHORT_UPCASE
5823 if (decc_efs_case_preserve)
5824 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5826 #ifdef NAML$M_OPEN_SPECIAL
5827 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5828 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5830 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5832 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5835 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5838 if (defesal != NULL)
5839 PerlMem_free(defesal);
5840 PerlMem_free(defesa);
5842 _ckvmssts_noperl(SS$_INSFMEM);
5846 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5847 if (*(rms_nam_verl(mynam)) != '\"')
5848 speclen = rms_nam_verl(mynam) - spec_buf;
5851 if (*(rms_nam_ver(mynam)) != '\"')
5852 speclen = rms_nam_ver(mynam) - spec_buf;
5856 /* If we didn't already trim version, copy down */
5857 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5858 if (speclen > rms_nam_verl(mynam) - spec_buf)
5860 (rms_nam_typel(mynam),
5861 rms_nam_verl(mynam),
5862 speclen - (rms_nam_verl(mynam) - spec_buf));
5863 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5866 if (speclen > rms_nam_ver(mynam) - spec_buf)
5868 (rms_nam_type(mynam),
5870 speclen - (rms_nam_ver(mynam) - spec_buf));
5871 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5876 /* Done with these copies of the input files */
5877 /*-------------------------------------------*/
5878 if (vmsfspec != NULL)
5879 PerlMem_free(vmsfspec);
5880 if (vmsdefspec != NULL)
5881 PerlMem_free(vmsdefspec);
5883 /* If we just had a directory spec on input, $PARSE "helpfully"
5884 * adds an empty name and type for us */
5885 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5886 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5887 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5888 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5889 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5890 speclen = rms_nam_namel(mynam) - spec_buf;
5895 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5896 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5897 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5898 speclen = rms_nam_name(mynam) - spec_buf;
5901 /* Posix format specifications must have matching quotes */
5902 if (speclen < (VMS_MAXRSS - 1)) {
5903 if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5904 if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5905 spec_buf[speclen] = '\"';
5910 spec_buf[speclen] = '\0';
5911 if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5913 /* Have we been working with an expanded, but not resultant, spec? */
5914 /* Also, convert back to Unix syntax if necessary. */
5918 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5919 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5920 rsl = rms_nam_rsll(mynam);
5924 rsl = rms_nam_rsl(mynam);
5927 /* rsl is not present, it means that spec_buf is either */
5928 /* esa or esal, and needs to be copied to outbuf */
5929 /* convert to Unix if desired */
5931 ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5933 /* VMS file specs are not in UTF-8 */
5934 if (fs_utf8 != NULL)
5936 strcpy(outbuf, spec_buf);
5941 /* Now spec_buf is either outbuf or outbufl */
5942 /* We need the result into outbuf */
5944 /* If we need this in UNIX, then we need another buffer */
5945 /* to keep things in order */
5947 char * new_src = NULL;
5948 if (spec_buf == outbuf) {
5949 new_src = PerlMem_malloc(VMS_MAXRSS);
5950 strcpy(new_src, spec_buf);
5954 ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5956 PerlMem_free(new_src);
5959 /* VMS file specs are not in UTF-8 */
5960 if (fs_utf8 != NULL)
5963 /* Copy the buffer if needed */
5964 if (outbuf != spec_buf)
5965 strcpy(outbuf, spec_buf);
5971 /* Need to clean up the search context */
5972 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5973 sts = rms_free_search_context(&myfab); /* Free search context */
5975 /* Clean up the extra buffers */
5979 if (outbufl != NULL)
5980 PerlMem_free(outbufl);
5982 /* Return the result */
5986 /* Common simple case - Expand an already VMS spec */
5988 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5989 opts |= PERL_RMSEXPAND_M_VMS_IN;
5990 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5993 /* Common simple case - Expand to a VMS spec */
5995 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5996 opts |= PERL_RMSEXPAND_M_VMS;
5997 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
6001 /* Entry point used by perl routines */
6004 (pTHX_ const char *filespec,
6007 const char *defspec,
6012 static char __rmsexpand_retbuf[VMS_MAXRSS];
6013 char * expanded, *ret_spec, *ret_buf;
6017 if (ret_buf == NULL) {
6019 Newx(expanded, VMS_MAXRSS, char);
6020 if (expanded == NULL)
6021 _ckvmssts(SS$_INSFMEM);
6024 ret_buf = __rmsexpand_retbuf;
6029 ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
6030 opts, fs_utf8, dfs_utf8);
6032 if (ret_spec == NULL) {
6033 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6041 /* External entry points */
6042 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6043 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
6044 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6045 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
6046 char *Perl_rmsexpand_utf8
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,0,def,opt, fs_utf8, dfs_utf8); }
6050 char *Perl_rmsexpand_utf8_ts
6051 (pTHX_ const char *spec, char *buf, const char *def,
6052 unsigned opt, int * fs_utf8, int * dfs_utf8)
6053 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
6057 ** The following routines are provided to make life easier when
6058 ** converting among VMS-style and Unix-style directory specifications.
6059 ** All will take input specifications in either VMS or Unix syntax. On
6060 ** failure, all return NULL. If successful, the routines listed below
6061 ** return a pointer to a buffer containing the appropriately
6062 ** reformatted spec (and, therefore, subsequent calls to that routine
6063 ** will clobber the result), while the routines of the same names with
6064 ** a _ts suffix appended will return a pointer to a mallocd string
6065 ** containing the appropriately reformatted spec.
6066 ** In all cases, only explicit syntax is altered; no check is made that
6067 ** the resulting string is valid or that the directory in question
6070 ** fileify_dirspec() - convert a directory spec into the name of the
6071 ** directory file (i.e. what you can stat() to see if it's a dir).
6072 ** The style (VMS or Unix) of the result is the same as the style
6073 ** of the parameter passed in.
6074 ** pathify_dirspec() - convert a directory spec into a path (i.e.
6075 ** what you prepend to a filename to indicate what directory it's in).
6076 ** The style (VMS or Unix) of the result is the same as the style
6077 ** of the parameter passed in.
6078 ** tounixpath() - convert a directory spec into a Unix-style path.
6079 ** tovmspath() - convert a directory spec into a VMS-style path.
6080 ** tounixspec() - convert any file spec into a Unix-style file spec.
6081 ** tovmsspec() - convert any file spec into a VMS-style spec.
6082 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
6084 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
6085 ** Permission is given to distribute this code as part of the Perl
6086 ** standard distribution under the terms of the GNU General Public
6087 ** License or the Perl Artistic License. Copies of each may be
6088 ** found in the Perl standard distribution.
6091 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6093 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
6095 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
6096 char *cp1, *cp2, *lastdir;
6097 char *trndir, *vmsdir;
6098 unsigned short int trnlnm_iter_count;
6102 if (utf8_fl != NULL)
6105 if (!dir || !*dir) {
6106 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6108 dirlen = strlen(dir);
6109 while (dirlen && dir[dirlen-1] == '/') --dirlen;
6110 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6111 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6118 if (dirlen > (VMS_MAXRSS - 1)) {
6119 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6122 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6123 if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6124 if (!strpbrk(dir+1,"/]>:") &&
6125 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6126 strcpy(trndir,*dir == '/' ? dir + 1: dir);
6127 trnlnm_iter_count = 0;
6128 while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6129 trnlnm_iter_count++;
6130 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6132 dirlen = strlen(trndir);
6135 strncpy(trndir,dir,dirlen);
6136 trndir[dirlen] = '\0';
6139 /* At this point we are done with *dir and use *trndir which is a
6140 * copy that can be modified. *dir must not be modified.
6143 /* If we were handed a rooted logical name or spec, treat it like a
6144 * simple directory, so that
6145 * $ Define myroot dev:[dir.]
6146 * ... do_fileify_dirspec("myroot",buf,1) ...
6147 * does something useful.
6149 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6150 trndir[--dirlen] = '\0';
6151 trndir[dirlen-1] = ']';
6153 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6154 trndir[--dirlen] = '\0';
6155 trndir[dirlen-1] = '>';
6158 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6159 /* If we've got an explicit filename, we can just shuffle the string. */
6160 if (*(cp1+1)) hasfilename = 1;
6161 /* Similarly, we can just back up a level if we've got multiple levels
6162 of explicit directories in a VMS spec which ends with directories. */
6164 for (cp2 = cp1; cp2 > trndir; cp2--) {
6166 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6167 /* fix-me, can not scan EFS file specs backward like this */
6168 *cp2 = *cp1; *cp1 = '\0';
6173 if (*cp2 == '[' || *cp2 == '<') break;
6178 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6179 if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6180 cp1 = strpbrk(trndir,"]:>");
6181 if (hasfilename || !cp1) { /* filename present or not VMS */
6183 if (decc_efs_charset && !cp1) {
6185 /* EFS handling for UNIX mode */
6187 /* Just remove the trailing '/' and we should be done */
6189 trndir_len = strlen(trndir);
6191 if (trndir_len > 1) {
6193 if (trndir[trndir_len] == '/') {
6194 trndir[trndir_len] = '\0';
6197 strcpy(buf, trndir);
6198 PerlMem_free(trndir);
6199 PerlMem_free(vmsdir);
6203 /* For non-EFS mode, this is left for backwards compatibility */
6204 /* For EFS mode, this is only done for VMS format filespecs as */
6205 /* Perl programs generally have problems when a UNIX format spec */
6206 /* returns a VMS format spec */
6207 if (trndir[0] == '.') {
6208 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6209 PerlMem_free(trndir);
6210 PerlMem_free(vmsdir);
6211 return int_fileify_dirspec("[]", buf, NULL);
6213 else if (trndir[1] == '.' &&
6214 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6215 PerlMem_free(trndir);
6216 PerlMem_free(vmsdir);
6217 return int_fileify_dirspec("[-]", buf, NULL);
6220 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
6221 dirlen -= 1; /* to last element */
6222 lastdir = strrchr(trndir,'/');
6224 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6225 /* If we have "/." or "/..", VMSify it and let the VMS code
6226 * below expand it, rather than repeating the code to handle
6227 * relative components of a filespec here */
6229 if (*(cp1+2) == '.') cp1++;
6230 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6232 if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6233 PerlMem_free(trndir);
6234 PerlMem_free(vmsdir);
6237 if (strchr(vmsdir,'/') != NULL) {
6238 /* If int_tovmsspec() returned it, it must have VMS syntax
6239 * delimiters in it, so it's a mixed VMS/Unix spec. We take
6240 * the time to check this here only so we avoid a recursion
6241 * loop; otherwise, gigo.
6243 PerlMem_free(trndir);
6244 PerlMem_free(vmsdir);
6245 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
6248 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6249 PerlMem_free(trndir);
6250 PerlMem_free(vmsdir);
6253 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6254 PerlMem_free(trndir);
6255 PerlMem_free(vmsdir);
6259 } while ((cp1 = strstr(cp1,"/.")) != NULL);
6260 lastdir = strrchr(trndir,'/');
6262 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6264 /* Ditto for specs that end in an MFD -- let the VMS code
6265 * figure out whether it's a real device or a rooted logical. */
6267 /* This should not happen any more. Allowing the fake /000000
6268 * in a UNIX pathname causes all sorts of problems when trying
6269 * to run in UNIX emulation. So the VMS to UNIX conversions
6270 * now remove the fake /000000 directories.
6273 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6274 if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6275 PerlMem_free(trndir);
6276 PerlMem_free(vmsdir);
6279 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6280 PerlMem_free(trndir);
6281 PerlMem_free(vmsdir);
6284 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6285 PerlMem_free(trndir);
6286 PerlMem_free(vmsdir);
6291 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6292 !(lastdir = cp1 = strrchr(trndir,']')) &&
6293 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6295 cp2 = strrchr(cp1,'.');
6297 int e_len, vs_len = 0;
6300 cp3 = strchr(cp2,';');
6301 e_len = strlen(cp2);
6303 vs_len = strlen(cp3);
6304 e_len = e_len - vs_len;
6306 is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6308 if (!decc_efs_charset) {
6309 /* If this is not EFS, then not a directory */
6310 PerlMem_free(trndir);
6311 PerlMem_free(vmsdir);
6313 set_vaxc_errno(RMS$_DIR);
6317 /* Ok, here we have an issue, technically if a .dir shows */
6318 /* from inside a directory, then we should treat it as */
6319 /* xxx^.dir.dir. But we do not have that context at this */
6320 /* point unless this is totally restructured, so we remove */
6321 /* The .dir for now, and fix this better later */
6322 dirlen = cp2 - trndir;
6328 retlen = dirlen + 6;
6329 memcpy(buf, trndir, dirlen);
6332 /* We've picked up everything up to the directory file name.
6333 Now just add the type and version, and we're set. */
6335 /* We should only add type for VMS syntax, but historically Perl
6336 has added it for UNIX style also */
6338 /* Fix me - we should not be using the same routine for VMS and
6339 UNIX format files. Things are too tangled so we need to lookup
6340 what syntax the output is */
6344 lastdir = strrchr(trndir,'/');
6348 lastdir = strpbrk(trndir,"]:>");
6354 if ((is_vms == 0) && (is_unix == 0)) {
6355 /* We still do not know? */
6356 is_unix = decc_filename_unix_report;
6361 if ((is_unix && !decc_efs_charset) || is_vms) {
6363 /* It is a bug to add a .dir to a UNIX format directory spec */
6364 /* However Perl on VMS may have programs that expect this so */
6365 /* If not using EFS character specifications allow it. */
6367 if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6368 /* Traditionally Perl expects filenames in lower case */
6369 strcat(buf, ".dir");
6371 /* VMS expects the .DIR to be in upper case */
6372 strcat(buf, ".DIR");
6375 /* It is also a bug to put a VMS format version on a UNIX file */
6376 /* specification. Perl self tests are looking for this */
6377 if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6380 PerlMem_free(trndir);
6381 PerlMem_free(vmsdir);
6384 else { /* VMS-style directory spec */
6386 char *esa, *esal, term, *cp;
6389 unsigned long int sts, cmplen, haslower = 0;
6390 unsigned int nam_fnb;
6392 struct FAB dirfab = cc$rms_fab;
6393 rms_setup_nam(savnam);
6394 rms_setup_nam(dirnam);
6396 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6397 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6399 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6400 esal = PerlMem_malloc(VMS_MAXRSS);
6401 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6403 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6404 rms_bind_fab_nam(dirfab, dirnam);
6405 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6406 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6407 #ifdef NAM$M_NO_SHORT_UPCASE
6408 if (decc_efs_case_preserve)
6409 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6412 for (cp = trndir; *cp; cp++)
6413 if (islower(*cp)) { haslower = 1; break; }
6414 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6415 if ((dirfab.fab$l_sts == RMS$_DIR) ||
6416 (dirfab.fab$l_sts == RMS$_DNF) ||
6417 (dirfab.fab$l_sts == RMS$_PRV)) {
6418 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6419 sts = sys$parse(&dirfab);
6425 PerlMem_free(trndir);
6426 PerlMem_free(vmsdir);
6428 set_vaxc_errno(dirfab.fab$l_sts);
6434 /* Does the file really exist? */
6435 if (sys$search(&dirfab)& STS$K_SUCCESS) {
6436 /* Yes; fake the fnb bits so we'll check type below */
6437 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6439 else { /* No; just work with potential name */
6440 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6443 fab_sts = dirfab.fab$l_sts;
6444 sts = rms_free_search_context(&dirfab);
6448 PerlMem_free(trndir);
6449 PerlMem_free(vmsdir);
6450 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
6456 /* Make sure we are using the right buffer */
6457 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6460 my_esa_len = rms_nam_esll(dirnam);
6464 my_esa_len = rms_nam_esl(dirnam);
6465 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6468 my_esa[my_esa_len] = '\0';
6469 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6470 cp1 = strchr(my_esa,']');
6471 if (!cp1) cp1 = strchr(my_esa,'>');
6472 if (cp1) { /* Should always be true */
6473 my_esa_len -= cp1 - my_esa - 1;
6474 memmove(my_esa, cp1 + 1, my_esa_len);
6477 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6478 /* Yep; check version while we're at it, if it's there. */
6479 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6480 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6481 /* Something other than .DIR[;1]. Bzzt. */
6482 sts = rms_free_search_context(&dirfab);
6486 PerlMem_free(trndir);
6487 PerlMem_free(vmsdir);
6489 set_vaxc_errno(RMS$_DIR);
6494 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6495 /* They provided at least the name; we added the type, if necessary, */
6496 strcpy(buf, my_esa);
6497 sts = rms_free_search_context(&dirfab);
6498 PerlMem_free(trndir);
6502 PerlMem_free(vmsdir);
6505 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6506 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6510 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6511 if (cp1 == NULL) { /* should never happen */
6512 sts = rms_free_search_context(&dirfab);
6513 PerlMem_free(trndir);
6517 PerlMem_free(vmsdir);
6522 retlen = strlen(my_esa);
6523 cp1 = strrchr(my_esa,'.');
6524 /* ODS-5 directory specifications can have extra "." in them. */
6525 /* Fix-me, can not scan EFS file specifications backwards */
6526 while (cp1 != NULL) {
6527 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6531 while ((cp1 > my_esa) && (*cp1 != '.'))
6538 if ((cp1) != NULL) {
6539 /* There's more than one directory in the path. Just roll back. */
6541 strcpy(buf, my_esa);
6544 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6545 /* Go back and expand rooted logical name */
6546 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6547 #ifdef NAM$M_NO_SHORT_UPCASE
6548 if (decc_efs_case_preserve)
6549 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6551 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6552 sts = rms_free_search_context(&dirfab);
6556 PerlMem_free(trndir);
6557 PerlMem_free(vmsdir);
6559 set_vaxc_errno(dirfab.fab$l_sts);
6563 /* This changes the length of the string of course */
6565 my_esa_len = rms_nam_esll(dirnam);
6567 my_esa_len = rms_nam_esl(dirnam);
6570 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6571 cp1 = strstr(my_esa,"][");
6572 if (!cp1) cp1 = strstr(my_esa,"]<");
6573 dirlen = cp1 - my_esa;
6574 memcpy(buf, my_esa, dirlen);
6575 if (!strncmp(cp1+2,"000000]",7)) {
6576 buf[dirlen-1] = '\0';
6577 /* fix-me Not full ODS-5, just extra dots in directories for now */
6578 cp1 = buf + dirlen - 1;
6584 if (*(cp1-1) != '^')
6589 if (*cp1 == '.') *cp1 = ']';
6591 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6592 memmove(cp1+1,"000000]",7);
6596 memmove(buf+dirlen, cp1+2, retlen-dirlen);
6598 /* Convert last '.' to ']' */
6600 while (*cp != '[') {
6603 /* Do not trip on extra dots in ODS-5 directories */
6604 if ((cp1 == buf) || (*(cp1-1) != '^'))
6608 if (*cp1 == '.') *cp1 = ']';
6610 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6611 memmove(cp1+1,"000000]",7);
6615 else { /* This is a top-level dir. Add the MFD to the path. */
6618 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6619 strcpy(cp2,":[000000]");
6624 sts = rms_free_search_context(&dirfab);
6625 /* We've set up the string up through the filename. Add the
6626 type and version, and we're done. */
6627 strcat(buf,".DIR;1");
6629 /* $PARSE may have upcased filespec, so convert output to lower
6630 * case if input contained any lowercase characters. */
6631 if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6632 PerlMem_free(trndir);
6636 PerlMem_free(vmsdir);
6639 } /* end of int_fileify_dirspec() */
6642 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6643 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6645 static char __fileify_retbuf[VMS_MAXRSS];
6646 char * fileified, *ret_spec, *ret_buf;
6650 if (ret_buf == NULL) {
6652 Newx(fileified, VMS_MAXRSS, char);
6653 if (fileified == NULL)
6654 _ckvmssts(SS$_INSFMEM);
6655 ret_buf = fileified;
6657 ret_buf = __fileify_retbuf;
6661 ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6663 if (ret_spec == NULL) {
6664 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6666 Safefree(fileified);
6670 } /* end of do_fileify_dirspec() */
6673 /* External entry points */
6674 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6675 { return do_fileify_dirspec(dir,buf,0,NULL); }
6676 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6677 { return do_fileify_dirspec(dir,buf,1,NULL); }
6678 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6679 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6680 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6681 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6683 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6684 char * v_spec, int v_len, char * r_spec, int r_len,
6685 char * d_spec, int d_len, char * n_spec, int n_len,
6686 char * e_spec, int e_len, char * vs_spec, int vs_len) {
6688 /* VMS specification - Try to do this the simple way */
6689 if ((v_len + r_len > 0) || (d_len > 0)) {
6692 /* No name or extension component, already a directory */
6693 if ((n_len + e_len + vs_len) == 0) {
6698 /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6699 /* This results from catfile() being used instead of catdir() */
6700 /* So even though it should not work, we need to allow it */
6702 /* If this is .DIR;1 then do a simple conversion */
6703 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6704 if (is_dir || (e_len == 0) && (d_len > 0)) {
6706 len = v_len + r_len + d_len - 1;
6707 char dclose = d_spec[d_len - 1];
6708 strncpy(buf, dir, len);
6711 strncpy(&buf[len], n_spec, n_len);
6714 buf[len + 1] = '\0';
6719 else if (d_len > 0) {
6720 /* In the olden days, a directory needed to have a .DIR */
6721 /* extension to be a valid directory, but now it could */
6722 /* be a symbolic link */
6724 len = v_len + r_len + d_len - 1;
6725 char dclose = d_spec[d_len - 1];
6726 strncpy(buf, dir, len);
6729 strncpy(&buf[len], n_spec, n_len);
6732 if (decc_efs_charset) {
6735 strncpy(&buf[len], e_spec, e_len);
6738 set_vaxc_errno(RMS$_DIR);
6744 buf[len + 1] = '\0';
6749 set_vaxc_errno(RMS$_DIR);
6755 set_vaxc_errno(RMS$_DIR);
6761 /* Internal routine to make sure or convert a directory to be in a */
6762 /* path specification. No utf8 flag because it is not changed or used */
6763 static char *int_pathify_dirspec(const char *dir, char *buf)
6765 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6766 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6767 char * exp_spec, *ret_spec;
6769 unsigned short int trnlnm_iter_count;
6773 if (vms_debug_fileify) {
6775 fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6777 fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6780 /* We may need to lower case the result if we translated */
6781 /* a logical name or got the current working directory */
6784 if (!dir || !*dir) {
6786 set_vaxc_errno(SS$_BADPARAM);
6790 trndir = PerlMem_malloc(VMS_MAXRSS);
6792 _ckvmssts_noperl(SS$_INSFMEM);
6794 /* If no directory specified use the current default */
6796 strcpy(trndir, dir);
6798 getcwd(trndir, VMS_MAXRSS - 1);
6802 /* now deal with bare names that could be logical names */
6803 trnlnm_iter_count = 0;
6804 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6805 && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6806 trnlnm_iter_count++;
6808 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6810 trnlen = strlen(trndir);
6812 /* Trap simple rooted lnms, and return lnm:[000000] */
6813 if (!strcmp(trndir+trnlen-2,".]")) {
6815 strcat(buf, ":[000000]");
6816 PerlMem_free(trndir);
6818 if (vms_debug_fileify) {
6819 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6825 /* At this point we do not work with *dir, but the copy in *trndir */
6827 if (need_to_lower && !decc_efs_case_preserve) {
6828 /* Legacy mode, lower case the returned value */
6829 __mystrtolower(trndir);
6833 /* Some special cases, '..', '.' */
6835 if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6836 /* Force UNIX filespec */
6840 /* Is this Unix or VMS format? */
6841 sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6842 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6843 &e_len, &vs_spec, &vs_len);
6846 /* Just a filename? */
6847 if ((v_len + r_len + d_len) == 0) {
6849 /* Now we have a problem, this could be Unix or VMS */
6850 /* We have to guess. .DIR usually means VMS */
6852 /* In UNIX report mode, the .DIR extension is removed */
6853 /* if one shows up, it is for a non-directory or a directory */
6854 /* in EFS charset mode */
6856 /* So if we are in Unix report mode, assume that this */
6857 /* is a relative Unix directory specification */
6860 if (!decc_filename_unix_report && decc_efs_charset) {
6862 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6865 /* Traditional mode, assume .DIR is directory */
6868 strncpy(&buf[2], n_spec, n_len);
6869 buf[n_len + 2] = ']';
6870 buf[n_len + 3] = '\0';
6871 PerlMem_free(trndir);
6872 if (vms_debug_fileify) {
6874 "int_pathify_dirspec: buf = %s\n",
6884 ret_spec = int_pathify_dirspec_simple(trndir, buf,
6885 v_spec, v_len, r_spec, r_len,
6886 d_spec, d_len, n_spec, n_len,
6887 e_spec, e_len, vs_spec, vs_len);
6889 if (ret_spec != NULL) {
6890 PerlMem_free(trndir);
6891 if (vms_debug_fileify) {
6893 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6898 /* Simple way did not work, which means that a logical name */
6899 /* was present for the directory specification. */
6900 /* Need to use an rmsexpand variant to decode it completely */
6901 exp_spec = PerlMem_malloc(VMS_MAXRSS);
6902 if (exp_spec == NULL)
6903 _ckvmssts_noperl(SS$_INSFMEM);
6905 ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6906 if (ret_spec != NULL) {
6907 sts = vms_split_path(exp_spec, &v_spec, &v_len,
6908 &r_spec, &r_len, &d_spec, &d_len,
6909 &n_spec, &n_len, &e_spec,
6910 &e_len, &vs_spec, &vs_len);
6912 ret_spec = int_pathify_dirspec_simple(
6913 exp_spec, buf, v_spec, v_len, r_spec, r_len,
6914 d_spec, d_len, n_spec, n_len,
6915 e_spec, e_len, vs_spec, vs_len);
6917 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6918 /* Legacy mode, lower case the returned value */
6919 __mystrtolower(ret_spec);
6922 set_vaxc_errno(RMS$_DIR);
6927 PerlMem_free(exp_spec);
6928 PerlMem_free(trndir);
6929 if (vms_debug_fileify) {
6930 if (ret_spec == NULL)
6931 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6934 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6939 /* Unix specification, Could be trivial conversion */
6941 dir_len = strlen(trndir);
6943 /* If the extended file character set is in effect */
6944 /* then pathify is simple */
6946 if (!decc_efs_charset) {
6947 /* Have to deal with traiing '.dir' or extra '.' */
6948 /* that should not be there in legacy mode, but is */
6954 lastslash = strrchr(trndir, '/');
6955 if (lastslash == NULL)
6962 /* '..' or '.' are valid directory components */
6964 if (lastslash[0] == '.') {
6965 if (lastslash[1] == '\0') {
6967 } else if (lastslash[1] == '.') {
6968 if (lastslash[2] == '\0') {
6971 /* And finally allow '...' */
6972 if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6980 lastdot = strrchr(lastslash, '.');
6982 if (lastdot != NULL) {
6985 /* '.dir' is discarded, and any other '.' is invalid */
6986 e_len = strlen(lastdot);
6988 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6991 dir_len = dir_len - 4;
6997 strcpy(buf, trndir);
6998 if (buf[dir_len - 1] != '/') {
7000 buf[dir_len + 1] = '\0';
7003 /* Under ODS-2 rules, '.' becomes '_', so fix it up */
7004 if (!decc_efs_charset) {
7007 if (str[0] == '.') {
7010 while ((dots[cnt] == '.') && (cnt < 3))
7013 if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
7019 for (; *str; ++str) {
7020 while (*str == '/') {
7026 /* Have to skip up to three dots which could be */
7027 /* directories, 3 dots being a VMS extension for Perl */
7030 while ((dots[cnt] == '.') && (cnt < 3)) {
7033 if (dots[cnt] == '\0')
7035 if ((cnt > 1) && (dots[cnt] != '/')) {
7041 /* too many dots? */
7042 if ((cnt == 0) || (cnt > 3)) {
7046 if (!dir_start && (*str == '.')) {
7051 PerlMem_free(trndir);
7053 if (vms_debug_fileify) {
7054 if (ret_spec == NULL)
7055 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
7058 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
7064 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
7065 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
7067 static char __pathify_retbuf[VMS_MAXRSS];
7068 char * pathified, *ret_spec, *ret_buf;
7072 if (ret_buf == NULL) {
7074 Newx(pathified, VMS_MAXRSS, char);
7075 if (pathified == NULL)
7076 _ckvmssts(SS$_INSFMEM);
7077 ret_buf = pathified;
7079 ret_buf = __pathify_retbuf;
7083 ret_spec = int_pathify_dirspec(dir, ret_buf);
7085 if (ret_spec == NULL) {
7086 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7088 Safefree(pathified);
7093 } /* end of do_pathify_dirspec() */
7096 /* External entry points */
7097 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
7098 { return do_pathify_dirspec(dir,buf,0,NULL); }
7099 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
7100 { return do_pathify_dirspec(dir,buf,1,NULL); }
7101 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
7102 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
7103 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
7104 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
7106 /* Internal tounixspec routine that does not use a thread context */
7107 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7108 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7110 char *dirend, *cp1, *cp3, *tmp;
7112 int devlen, dirlen, retlen = VMS_MAXRSS;
7113 int expand = 1; /* guarantee room for leading and trailing slashes */
7114 unsigned short int trnlnm_iter_count;
7116 if (utf8_fl != NULL)
7119 if (vms_debug_fileify) {
7121 fprintf(stderr, "int_tounixspec: spec = NULL\n");
7123 fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7129 set_vaxc_errno(SS$_BADPARAM);
7132 if (strlen(spec) > (VMS_MAXRSS-1)) {
7134 set_vaxc_errno(SS$_BUFFEROVF);
7138 /* New VMS specific format needs translation
7139 * glob passes filenames with trailing '\n' and expects this preserved.
7141 if (decc_posix_compliant_pathnames) {
7142 if (strncmp(spec, "\"^UP^", 5) == 0) {
7148 tunix = PerlMem_malloc(VMS_MAXRSS);
7149 if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7150 strcpy(tunix, spec);
7151 tunix_len = strlen(tunix);
7153 if (tunix[tunix_len - 1] == '\n') {
7154 tunix[tunix_len - 1] = '\"';
7155 tunix[tunix_len] = '\0';
7159 uspec = decc$translate_vms(tunix);
7160 PerlMem_free(tunix);
7161 if ((int)uspec > 0) {
7167 /* If we can not translate it, makemaker wants as-is */
7175 cmp_rslt = 0; /* Presume VMS */
7176 cp1 = strchr(spec, '/');
7180 /* Look for EFS ^/ */
7181 if (decc_efs_charset) {
7182 while (cp1 != NULL) {
7185 /* Found illegal VMS, assume UNIX */
7190 cp1 = strchr(cp1, '/');
7194 /* Look for "." and ".." */
7195 if (decc_filename_unix_report) {
7196 if (spec[0] == '.') {
7197 if ((spec[1] == '\0') || (spec[1] == '\n')) {
7201 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7207 /* This is already UNIX or at least nothing VMS understands */
7210 if (vms_debug_fileify) {
7211 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7218 dirend = strrchr(spec,']');
7219 if (dirend == NULL) dirend = strrchr(spec,'>');
7220 if (dirend == NULL) dirend = strchr(spec,':');
7221 if (dirend == NULL) {
7223 if (vms_debug_fileify) {
7224 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7229 /* Special case 1 - sys$posix_root = / */
7230 #if __CRTL_VER >= 70000000
7231 if (!decc_disable_posix_root) {
7232 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7240 /* Special case 2 - Convert NLA0: to /dev/null */
7241 #if __CRTL_VER < 70000000
7242 cmp_rslt = strncmp(spec,"NLA0:", 5);
7244 cmp_rslt = strncmp(spec,"nla0:", 5);
7246 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7248 if (cmp_rslt == 0) {
7249 strcpy(rslt, "/dev/null");
7252 if (spec[6] != '\0') {
7259 /* Also handle special case "SYS$SCRATCH:" */
7260 #if __CRTL_VER < 70000000
7261 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7263 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7265 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7267 tmp = PerlMem_malloc(VMS_MAXRSS);
7268 if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7269 if (cmp_rslt == 0) {
7272 islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7274 strcpy(rslt, "/tmp");
7277 if (spec[12] != '\0') {
7285 if (*cp2 != '[' && *cp2 != '<') {
7288 else { /* the VMS spec begins with directories */
7290 if (*cp2 == ']' || *cp2 == '>') {
7291 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7295 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7296 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7298 if (vms_debug_fileify) {
7299 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7303 trnlnm_iter_count = 0;
7306 while (*cp3 != ':' && *cp3) cp3++;
7308 if (strchr(cp3,']') != NULL) break;
7309 trnlnm_iter_count++;
7310 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7311 } while (vmstrnenv(tmp,tmp,0,fildev,0));
7316 *(cp1++) = *(cp3++);
7317 if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7319 set_errno(ENAMETOOLONG);
7320 set_vaxc_errno(SS$_BUFFEROVF);
7321 if (vms_debug_fileify) {
7322 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7324 return NULL; /* No room */
7329 if ((*cp2 == '^')) {
7330 /* EFS file escape, pass the next character as is */
7331 /* Fix me: HEX encoding for Unicode not implemented */
7334 else if ( *cp2 == '.') {
7335 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7336 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7343 for (; cp2 <= dirend; cp2++) {
7344 if ((*cp2 == '^')) {
7345 /* EFS file escape, pass the next character as is */
7346 /* Fix me: HEX encoding for Unicode not implemented */
7347 *(cp1++) = *(++cp2);
7348 /* An escaped dot stays as is -- don't convert to slash */
7349 if (*cp2 == '.') cp2++;
7353 if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7355 else if (*cp2 == ']' || *cp2 == '>') {
7356 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7358 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7360 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7361 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7362 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7363 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7364 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7366 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7367 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7371 else if (*cp2 == '-') {
7372 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7373 while (*cp2 == '-') {
7375 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7377 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7378 /* filespecs like */
7379 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
7380 if (vms_debug_fileify) {
7381 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7386 else *(cp1++) = *cp2;
7388 else *(cp1++) = *cp2;
7390 /* Translate the rest of the filename. */
7395 /* Fixme - for compatibility with the CRTL we should be removing */
7396 /* spaces from the file specifications, but this may show that */
7397 /* some tests that were appearing to pass are not really passing */
7403 /* Fix me hex expansions not implemented */
7404 cp2++; /* '^.' --> '.' and other. */
7410 *(cp1++) = *(cp2++);
7415 if (decc_filename_unix_no_version) {
7416 /* Easy, drop the version */
7421 /* Punt - passing the version as a dot will probably */
7422 /* break perl in weird ways, but so did passing */
7423 /* through the ; as a version. Follow the CRTL and */
7424 /* hope for the best. */
7431 /* We will need to fix this properly later */
7432 /* As Perl may be installed on an ODS-5 volume, but not */
7433 /* have the EFS_CHARSET enabled, it still may encounter */
7434 /* filenames with extra dots in them, and a precedent got */
7435 /* set which allowed them to work, that we will uphold here */
7436 /* If extra dots are present in a name and no ^ is on them */
7437 /* VMS assumes that the first one is the extension delimiter */
7438 /* the rest have an implied ^. */
7440 /* this is also a conflict as the . is also a version */
7441 /* delimiter in VMS, */
7443 *(cp1++) = *(cp2++);
7447 /* This is an extension */
7448 if (decc_readdir_dropdotnotype) {
7450 if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7451 /* Drop the dot for the extension */
7459 *(cp1++) = *(cp2++);
7464 /* This still leaves /000000/ when working with a
7465 * VMS device root or concealed root.
7471 ulen = strlen(rslt);
7473 /* Get rid of "000000/ in rooted filespecs */
7475 zeros = strstr(rslt, "/000000/");
7476 if (zeros != NULL) {
7478 mlen = ulen - (zeros - rslt) - 7;
7479 memmove(zeros, &zeros[7], mlen);
7486 if (vms_debug_fileify) {
7487 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7491 } /* end of int_tounixspec() */
7494 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7495 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7497 static char __tounixspec_retbuf[VMS_MAXRSS];
7498 char * unixspec, *ret_spec, *ret_buf;
7502 if (ret_buf == NULL) {
7504 Newx(unixspec, VMS_MAXRSS, char);
7505 if (unixspec == NULL)
7506 _ckvmssts(SS$_INSFMEM);
7509 ret_buf = __tounixspec_retbuf;
7513 ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7515 if (ret_spec == NULL) {
7516 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7523 } /* end of do_tounixspec() */
7525 /* External entry points */
7526 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7527 { return do_tounixspec(spec,buf,0, NULL); }
7528 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7529 { return do_tounixspec(spec,buf,1, NULL); }
7530 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7531 { return do_tounixspec(spec,buf,0, utf8_fl); }
7532 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7533 { return do_tounixspec(spec,buf,1, utf8_fl); }
7535 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7538 This procedure is used to identify if a path is based in either
7539 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7540 it returns the OpenVMS format directory for it.
7542 It is expecting specifications of only '/' or '/xxxx/'
7544 If a posix root does not exist, or 'xxxx' is not a directory
7545 in the posix root, it returns a failure.
7547 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7549 It is used only internally by posix_to_vmsspec_hardway().
7552 static int posix_root_to_vms
7553 (char *vmspath, int vmspath_len,
7554 const char *unixpath,
7555 const int * utf8_fl)
7558 struct FAB myfab = cc$rms_fab;
7559 rms_setup_nam(mynam);
7560 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7561 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7562 char * esa, * esal, * rsa, * rsal;
7569 unixlen = strlen(unixpath);
7574 #if __CRTL_VER >= 80200000
7575 /* If not a posix spec already, convert it */
7576 if (decc_posix_compliant_pathnames) {
7577 if (strncmp(unixpath,"\"^UP^",5) != 0) {
7578 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7581 /* This is already a VMS specification, no conversion */
7583 strncpy(vmspath,unixpath, vmspath_len);
7592 /* Check to see if this is under the POSIX root */
7593 if (decc_disable_posix_root) {
7597 /* Skip leading / */
7598 if (unixpath[0] == '/') {
7604 strcpy(vmspath,"SYS$POSIX_ROOT:");
7606 /* If this is only the / , or blank, then... */
7607 if (unixpath[0] == '\0') {
7608 /* by definition, this is the answer */
7612 /* Need to look up a directory */
7616 /* Copy and add '^' escape characters as needed */
7619 while (unixpath[i] != 0) {
7622 j += copy_expand_unix_filename_escape
7623 (&vmspath[j], &unixpath[i], &k, utf8_fl);
7627 path_len = strlen(vmspath);
7628 if (vmspath[path_len - 1] == '/')
7630 vmspath[path_len] = ']';
7632 vmspath[path_len] = '\0';
7635 vmspath[vmspath_len] = 0;
7636 if (unixpath[unixlen - 1] == '/')
7638 esal = PerlMem_malloc(VMS_MAXRSS);
7639 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7640 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7641 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7642 rsal = PerlMem_malloc(VMS_MAXRSS);
7643 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7644 rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7645 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7646 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7647 rms_bind_fab_nam(myfab, mynam);
7648 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7649 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7650 if (decc_efs_case_preserve)
7651 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7652 #ifdef NAML$M_OPEN_SPECIAL
7653 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7656 /* Set up the remaining naml fields */
7657 sts = sys$parse(&myfab);
7659 /* It failed! Try again as a UNIX filespec */
7668 /* get the Device ID and the FID */
7669 sts = sys$search(&myfab);
7671 /* These are no longer needed */
7676 /* on any failure, returned the POSIX ^UP^ filespec */
7681 specdsc.dsc$a_pointer = vmspath;
7682 specdsc.dsc$w_length = vmspath_len;
7684 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7685 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7686 sts = lib$fid_to_name
7687 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7689 /* on any failure, returned the POSIX ^UP^ filespec */
7691 /* This can happen if user does not have permission to read directories */
7692 if (strncmp(unixpath,"\"^UP^",5) != 0)
7693 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7695 strcpy(vmspath, unixpath);
7698 vmspath[specdsc.dsc$w_length] = 0;
7700 /* Are we expecting a directory? */
7701 if (dir_flag != 0) {
7707 i = specdsc.dsc$w_length - 1;
7711 /* Version must be '1' */
7712 if (vmspath[i--] != '1')
7714 /* Version delimiter is one of ".;" */
7715 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7718 if (vmspath[i--] != 'R')
7720 if (vmspath[i--] != 'I')
7722 if (vmspath[i--] != 'D')
7724 if (vmspath[i--] != '.')
7726 eptr = &vmspath[i+1];
7728 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7729 if (vmspath[i-1] != '^') {
7737 /* Get rid of 6 imaginary zero directory filename */
7738 vmspath[i+1] = '\0';
7742 if (vmspath[i] == '0')
7756 /* /dev/mumble needs to be handled special.
7757 /dev/null becomes NLA0:, And there is the potential for other stuff
7758 like /dev/tty which may need to be mapped to something.
7762 slash_dev_special_to_vms
7763 (const char * unixptr,
7773 nextslash = strchr(unixptr, '/');
7774 len = strlen(unixptr);
7775 if (nextslash != NULL)
7776 len = nextslash - unixptr;
7777 cmp = strncmp("null", unixptr, 5);
7779 if (vmspath_len >= 6) {
7780 strcpy(vmspath, "_NLA0:");
7787 /* The built in routines do not understand perl's special needs, so
7788 doing a manual conversion from UNIX to VMS
7790 If the utf8_fl is not null and points to a non-zero value, then
7791 treat 8 bit characters as UTF-8.
7793 The sequence starting with '$(' and ending with ')' will be passed
7794 through with out interpretation instead of being escaped.
7797 static int posix_to_vmsspec_hardway
7798 (char *vmspath, int vmspath_len,
7799 const char *unixpath,
7804 const char *unixptr;
7805 const char *unixend;
7807 const char *lastslash;
7808 const char *lastdot;
7814 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7815 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7817 if (utf8_fl != NULL)
7823 /* Ignore leading "/" characters */
7824 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7827 unixlen = strlen(unixptr);
7829 /* Do nothing with blank paths */
7836 /* This could have a "^UP^ on the front */
7837 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7843 lastslash = strrchr(unixptr,'/');
7844 lastdot = strrchr(unixptr,'.');
7845 unixend = strrchr(unixptr,'\"');
7846 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7847 unixend = unixptr + unixlen;
7850 /* last dot is last dot or past end of string */
7851 if (lastdot == NULL)
7852 lastdot = unixptr + unixlen;
7854 /* if no directories, set last slash to beginning of string */
7855 if (lastslash == NULL) {
7856 lastslash = unixptr;
7859 /* Watch out for trailing "." after last slash, still a directory */
7860 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7861 lastslash = unixptr + unixlen;
7864 /* Watch out for traiing ".." after last slash, still a directory */
7865 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7866 lastslash = unixptr + unixlen;
7869 /* dots in directories are aways escaped */
7870 if (lastdot < lastslash)
7871 lastdot = unixptr + unixlen;
7874 /* if (unixptr < lastslash) then we are in a directory */
7881 /* Start with the UNIX path */
7882 if (*unixptr != '/') {
7883 /* relative paths */
7885 /* If allowing logical names on relative pathnames, then handle here */
7886 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7887 !decc_posix_compliant_pathnames) {
7893 /* Find the next slash */
7894 nextslash = strchr(unixptr,'/');
7896 esa = PerlMem_malloc(vmspath_len);
7897 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7899 trn = PerlMem_malloc(VMS_MAXRSS);
7900 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7902 if (nextslash != NULL) {
7904 seg_len = nextslash - unixptr;
7905 strncpy(esa, unixptr, seg_len);
7909 strcpy(esa, unixptr);
7910 seg_len = strlen(unixptr);
7912 /* trnlnm(section) */
7913 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7916 /* Now fix up the directory */
7918 /* Split up the path to find the components */
7919 sts = vms_split_path
7938 /* A logical name must be a directory or the full
7939 specification. It is only a full specification if
7940 it is the only component */
7941 if ((unixptr[seg_len] == '\0') ||
7942 (unixptr[seg_len+1] == '\0')) {
7944 /* Is a directory being required? */
7945 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7946 /* Not a logical name */
7951 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7952 /* This must be a directory */
7953 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7954 strcpy(vmsptr, esa);
7955 vmslen=strlen(vmsptr);
7956 vmsptr[vmslen] = ':';
7958 vmsptr[vmslen] = '\0';
7966 /* must be dev/directory - ignore version */
7967 if ((n_len + e_len) != 0)
7970 /* transfer the volume */
7971 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7972 strncpy(vmsptr, v_spec, v_len);
7978 /* unroot the rooted directory */
7979 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7981 r_spec[r_len - 1] = ']';
7983 /* This should not be there, but nothing is perfect */
7985 cmp = strcmp(&r_spec[1], "000000.");
7995 strncpy(vmsptr, r_spec, r_len);
8001 /* Bring over the directory. */
8003 ((d_len + vmslen) < vmspath_len)) {
8005 d_spec[d_len - 1] = ']';
8007 cmp = strcmp(&d_spec[1], "000000.");
8018 /* Remove the redundant root */
8026 strncpy(vmsptr, d_spec, d_len);
8040 if (lastslash > unixptr) {
8043 /* skip leading ./ */
8045 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
8051 /* Are we still in a directory? */
8052 if (unixptr <= lastslash) {
8057 /* if not backing up, then it is relative forward. */
8058 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
8059 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
8067 /* Perl wants an empty directory here to tell the difference
8068 * between a DCL commmand and a filename
8077 /* Handle two special files . and .. */
8078 if (unixptr[0] == '.') {
8079 if (&unixptr[1] == unixend) {
8086 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
8097 else { /* Absolute PATH handling */
8101 /* Need to find out where root is */
8103 /* In theory, this procedure should never get an absolute POSIX pathname
8104 * that can not be found on the POSIX root.
8105 * In practice, that can not be relied on, and things will show up
8106 * here that are a VMS device name or concealed logical name instead.
8107 * So to make things work, this procedure must be tolerant.
8109 esa = PerlMem_malloc(vmspath_len);
8110 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8113 nextslash = strchr(&unixptr[1],'/');
8115 if (nextslash != NULL) {
8117 seg_len = nextslash - &unixptr[1];
8118 strncpy(vmspath, unixptr, seg_len + 1);
8119 vmspath[seg_len+1] = 0;
8122 cmp = strncmp(vmspath, "dev", 4);
8124 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8125 if (sts = SS$_NORMAL)
8129 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8132 if ($VMS_STATUS_SUCCESS(sts)) {
8133 /* This is verified to be a real path */
8135 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8136 if ($VMS_STATUS_SUCCESS(sts)) {
8137 strcpy(vmspath, esa);
8138 vmslen = strlen(vmspath);
8139 vmsptr = vmspath + vmslen;
8141 if (unixptr < lastslash) {
8150 cmp = strcmp(rptr,"000000.");
8155 } /* removing 6 zeros */
8156 } /* vmslen < 7, no 6 zeros possible */
8157 } /* Not in a directory */
8158 } /* Posix root found */
8160 /* No posix root, fall back to default directory */
8161 strcpy(vmspath, "SYS$DISK:[");
8162 vmsptr = &vmspath[10];
8164 if (unixptr > lastslash) {
8173 } /* end of verified real path handling */
8178 /* Ok, we have a device or a concealed root that is not in POSIX
8179 * or we have garbage. Make the best of it.
8182 /* Posix to VMS destroyed this, so copy it again */
8183 strncpy(vmspath, &unixptr[1], seg_len);
8184 vmspath[seg_len] = 0;
8186 vmsptr = &vmsptr[vmslen];
8189 /* Now do we need to add the fake 6 zero directory to it? */
8191 if ((*lastslash == '/') && (nextslash < lastslash)) {
8192 /* No there is another directory */
8199 /* now we have foo:bar or foo:[000000]bar to decide from */
8200 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8202 if (!islnm && !decc_posix_compliant_pathnames) {
8204 cmp = strncmp("bin", vmspath, 4);
8206 /* bin => SYS$SYSTEM: */
8207 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8210 /* tmp => SYS$SCRATCH: */
8211 cmp = strncmp("tmp", vmspath, 4);
8213 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8218 trnend = islnm ? islnm - 1 : 0;
8220 /* if this was a logical name, ']' or '>' must be present */
8221 /* if not a logical name, then assume a device and hope. */
8222 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8224 /* if log name and trailing '.' then rooted - treat as device */
8225 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8227 /* Fix me, if not a logical name, a device lookup should be
8228 * done to see if the device is file structured. If the device
8229 * is not file structured, the 6 zeros should not be put on.
8231 * As it is, perl is occasionally looking for dev:[000000]tty.
8232 * which looks a little strange.
8234 * Not that easy to detect as "/dev" may be file structured with
8235 * special device files.
8238 if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
8239 (&nextslash[1] == unixend)) {
8240 /* No real directory present */
8245 /* Put the device delimiter on */
8248 unixptr = nextslash;
8251 /* Start directory if needed */
8252 if (!islnm || add_6zero) {
8258 /* add fake 000000] if needed */
8271 } /* non-POSIX translation */
8273 } /* End of relative/absolute path handling */
8275 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8282 if (dir_start != 0) {
8284 /* First characters in a directory are handled special */
8285 while ((*unixptr == '/') ||
8286 ((*unixptr == '.') &&
8287 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8288 (&unixptr[1]==unixend)))) {
8293 /* Skip redundant / in specification */
8294 while ((*unixptr == '/') && (dir_start != 0)) {
8297 if (unixptr == lastslash)
8300 if (unixptr == lastslash)
8303 /* Skip redundant ./ characters */
8304 while ((*unixptr == '.') &&
8305 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8308 if (unixptr == lastslash)
8310 if (*unixptr == '/')
8313 if (unixptr == lastslash)
8316 /* Skip redundant ../ characters */
8317 while ((*unixptr == '.') && (unixptr[1] == '.') &&
8318 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8319 /* Set the backing up flag */
8325 unixptr++; /* first . */
8326 unixptr++; /* second . */
8327 if (unixptr == lastslash)
8329 if (*unixptr == '/') /* The slash */
8332 if (unixptr == lastslash)
8335 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8336 /* Not needed when VMS is pretending to be UNIX. */
8338 /* Is this loop stuck because of too many dots? */
8339 if (loop_flag == 0) {
8340 /* Exit the loop and pass the rest through */
8345 /* Are we done with directories yet? */
8346 if (unixptr >= lastslash) {
8348 /* Watch out for trailing dots */
8357 if (*unixptr == '/')
8361 /* Have we stopped backing up? */
8366 /* dir_start continues to be = 1 */
8368 if (*unixptr == '-') {
8370 *vmsptr++ = *unixptr++;
8374 /* Now are we done with directories yet? */
8375 if (unixptr >= lastslash) {
8377 /* Watch out for trailing dots */
8393 if (unixptr >= unixend)
8396 /* Normal characters - More EFS work probably needed */
8402 /* remove multiple / */
8403 while (unixptr[1] == '/') {
8406 if (unixptr == lastslash) {
8407 /* Watch out for trailing dots */
8419 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8420 /* Not needed when VMS is pretending to be UNIX. */
8424 if (unixptr != unixend)
8429 if ((unixptr < lastdot) || (unixptr < lastslash) ||
8430 (&unixptr[1] == unixend)) {
8436 /* trailing dot ==> '^..' on VMS */
8437 if (unixptr == unixend) {
8445 *vmsptr++ = *unixptr++;
8449 if (quoted && (&unixptr[1] == unixend)) {
8453 in_cnt = copy_expand_unix_filename_escape
8454 (vmsptr, unixptr, &out_cnt, utf8_fl);
8464 in_cnt = copy_expand_unix_filename_escape
8465 (vmsptr, unixptr, &out_cnt, utf8_fl);
8472 /* Make sure directory is closed */
8473 if (unixptr == lastslash) {
8475 vmsptr2 = vmsptr - 1;
8477 if (*vmsptr2 != ']') {
8480 /* directories do not end in a dot bracket */
8481 if (*vmsptr2 == '.') {
8485 if (*vmsptr2 != '^') {
8486 vmsptr--; /* back up over the dot */
8494 /* Add a trailing dot if a file with no extension */
8495 vmsptr2 = vmsptr - 1;
8497 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8498 (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8509 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8510 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8515 /* If a UTF8 flag is being passed, honor it */
8517 if (utf8_fl != NULL) {
8518 utf8_flag = *utf8_fl;
8523 /* If there is a possibility of UTF8, then if any UTF8 characters
8524 are present, then they must be converted to VTF-7
8526 result = strcpy(rslt, path); /* FIX-ME */
8529 result = strcpy(rslt, path);
8536 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8537 static char *int_tovmsspec
8538 (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8544 unsigned long int infront = 0, hasdir = 1;
8547 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8548 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8550 if (vms_debug_fileify) {
8552 fprintf(stderr, "int_tovmsspec: path = NULL\n");
8554 fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8558 /* If we fail, we should be setting errno */
8560 set_vaxc_errno(SS$_BADPARAM);
8563 rslt_len = VMS_MAXRSS-1;
8565 /* '.' and '..' are "[]" and "[-]" for a quick check */
8566 if (path[0] == '.') {
8567 if (path[1] == '\0') {
8569 if (utf8_flag != NULL)
8574 if (path[1] == '.' && path[2] == '\0') {
8576 if (utf8_flag != NULL)
8583 /* Posix specifications are now a native VMS format */
8584 /*--------------------------------------------------*/
8585 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8586 if (decc_posix_compliant_pathnames) {
8587 if (strncmp(path,"\"^UP^",5) == 0) {
8588 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8594 /* This is really the only way to see if this is already in VMS format */
8595 sts = vms_split_path
8610 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8611 replacement, because the above parse just took care of most of
8612 what is needed to do vmspath when the specification is already
8615 And if it is not already, it is easier to do the conversion as
8616 part of this routine than to call this routine and then work on
8620 /* If VMS punctuation was found, it is already VMS format */
8621 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8622 if (utf8_flag != NULL)
8625 if (vms_debug_fileify) {
8626 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8630 /* Now, what to do with trailing "." cases where there is no
8631 extension? If this is a UNIX specification, and EFS characters
8632 are enabled, then the trailing "." should be converted to a "^.".
8633 But if this was already a VMS specification, then it should be
8636 So in the case of ambiguity, leave the specification alone.
8640 /* If there is a possibility of UTF8, then if any UTF8 characters
8641 are present, then they must be converted to VTF-7
8643 if (utf8_flag != NULL)
8646 if (vms_debug_fileify) {
8647 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8652 dirend = strrchr(path,'/');
8654 if (dirend == NULL) {
8658 /* If we get here with no UNIX directory delimiters, then this is
8659 not a complete file specification, either garbage a UNIX glob
8660 specification that can not be converted to a VMS wildcard, or
8661 it a UNIX shell macro. MakeMaker wants shell macros passed
8664 utf8 flag setting needs to be preserved.
8669 macro_start = strchr(path,'$');
8670 if (macro_start != NULL) {
8671 if (macro_start[1] == '(') {
8675 if ((decc_efs_charset == 0) || (has_macro)) {
8677 if (vms_debug_fileify) {
8678 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8684 /* If EFS charset mode active, handle the conversion */
8685 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8686 if (decc_efs_charset) {
8687 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8688 if (vms_debug_fileify) {
8689 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8695 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
8696 if (!*(dirend+2)) dirend +=2;
8697 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8698 if (decc_efs_charset == 0) {
8699 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8705 lastdot = strrchr(cp2,'.');
8711 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8713 if (decc_disable_posix_root) {
8714 strcpy(rslt,"sys$disk:[000000]");
8717 strcpy(rslt,"sys$posix_root:[000000]");
8719 if (utf8_flag != NULL)
8721 if (vms_debug_fileify) {
8722 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8726 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8728 trndev = PerlMem_malloc(VMS_MAXRSS);
8729 if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8730 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8732 /* DECC special handling */
8734 if (strcmp(rslt,"bin") == 0) {
8735 strcpy(rslt,"sys$system");
8738 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8740 else if (strcmp(rslt,"tmp") == 0) {
8741 strcpy(rslt,"sys$scratch");
8744 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8746 else if (!decc_disable_posix_root) {
8747 strcpy(rslt, "sys$posix_root");
8751 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8752 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8754 else if (strcmp(rslt,"dev") == 0) {
8755 if (strncmp(cp2,"/null", 5) == 0) {
8756 if ((cp2[5] == 0) || (cp2[5] == '/')) {
8757 strcpy(rslt,"NLA0");
8761 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8767 trnend = islnm ? strlen(trndev) - 1 : 0;
8768 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8769 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8770 /* If the first element of the path is a logical name, determine
8771 * whether it has to be translated so we can add more directories. */
8772 if (!islnm || rooted) {
8775 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8779 if (cp2 != dirend) {
8780 strcpy(rslt,trndev);
8781 cp1 = rslt + trnend;
8788 if (decc_disable_posix_root) {
8794 PerlMem_free(trndev);
8799 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8800 cp2 += 2; /* skip over "./" - it's redundant */
8801 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8803 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8804 *(cp1++) = '-'; /* "../" --> "-" */
8807 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8808 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8809 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8810 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8813 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8814 /* Escape the extra dots in EFS file specifications */
8817 if (cp2 > dirend) cp2 = dirend;
8819 else *(cp1++) = '.';
8821 for (; cp2 < dirend; cp2++) {
8823 if (*(cp2-1) == '/') continue;
8824 if (*(cp1-1) != '.') *(cp1++) = '.';
8827 else if (!infront && *cp2 == '.') {
8828 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8829 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
8830 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8831 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8832 else if (*(cp1-2) == '[') *(cp1-1) = '-';
8833 else { /* back up over previous directory name */
8835 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8836 if (*(cp1-1) == '[') {
8837 memcpy(cp1,"000000.",7);
8842 if (cp2 == dirend) break;
8844 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8845 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8846 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8847 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8849 *(cp1++) = '.'; /* Simulate trailing '/' */
8850 cp2 += 2; /* for loop will incr this to == dirend */
8852 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8855 if (decc_efs_charset == 0)
8856 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8858 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8864 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
8866 if (decc_efs_charset == 0)
8873 else *(cp1++) = *cp2;
8877 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8878 if (hasdir) *(cp1++) = ']';
8879 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
8880 /* fixme for ODS5 */
8887 if (decc_efs_charset == 0)
8898 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8899 decc_readdir_dropdotnotype) {
8904 /* trailing dot ==> '^..' on VMS */
8911 *(cp1++) = *(cp2++);
8916 /* This could be a macro to be passed through */
8917 *(cp1++) = *(cp2++);
8919 const char * save_cp2;
8923 /* paranoid check */
8929 *(cp1++) = *(cp2++);
8930 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8931 *(cp1++) = *(cp2++);
8932 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8933 *(cp1++) = *(cp2++);
8936 *(cp1++) = *(cp2++);
8940 if (is_macro == 0) {
8941 /* Not really a macro - never mind */
8954 /* Don't escape again if following character is
8955 * already something we escape.
8957 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8958 *(cp1++) = *(cp2++);
8961 /* But otherwise fall through and escape it. */
8979 *(cp1++) = *(cp2++);
8982 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8983 * which is wrong. UNIX notation should be ".dir." unless
8984 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8985 * changing this behavior could break more things at this time.
8986 * efs character set effectively does not allow "." to be a version
8987 * delimiter as a further complication about changing this.
8989 if (decc_filename_unix_report != 0) {
8992 *(cp1++) = *(cp2++);
8995 *(cp1++) = *(cp2++);
8998 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
9002 /* Fix me for "^]", but that requires making sure that you do
9003 * not back up past the start of the filename
9005 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
9010 if (utf8_flag != NULL)
9012 if (vms_debug_fileify) {
9013 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
9017 } /* end of int_tovmsspec() */
9020 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
9021 static char *mp_do_tovmsspec
9022 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
9023 static char __tovmsspec_retbuf[VMS_MAXRSS];
9024 char * vmsspec, *ret_spec, *ret_buf;
9028 if (ret_buf == NULL) {
9030 Newx(vmsspec, VMS_MAXRSS, char);
9031 if (vmsspec == NULL)
9032 _ckvmssts(SS$_INSFMEM);
9035 ret_buf = __tovmsspec_retbuf;
9039 ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
9041 if (ret_spec == NULL) {
9042 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
9049 } /* end of mp_do_tovmsspec() */
9051 /* External entry points */
9052 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
9053 { return do_tovmsspec(path,buf,0,NULL); }
9054 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
9055 { return do_tovmsspec(path,buf,1,NULL); }
9056 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9057 { return do_tovmsspec(path,buf,0,utf8_fl); }
9058 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9059 { return do_tovmsspec(path,buf,1,utf8_fl); }
9061 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
9062 /* Internal routine for use with out an explict context present */
9063 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
9065 char * ret_spec, *pathified;
9070 pathified = PerlMem_malloc(VMS_MAXRSS);
9071 if (pathified == NULL)
9072 _ckvmssts_noperl(SS$_INSFMEM);
9074 ret_spec = int_pathify_dirspec(path, pathified);
9076 if (ret_spec == NULL) {
9077 PerlMem_free(pathified);
9081 ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
9083 PerlMem_free(pathified);
9088 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
9089 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9090 static char __tovmspath_retbuf[VMS_MAXRSS];
9092 char *pathified, *vmsified, *cp;
9094 if (path == NULL) return NULL;
9095 pathified = PerlMem_malloc(VMS_MAXRSS);
9096 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9097 if (int_pathify_dirspec(path, pathified) == NULL) {
9098 PerlMem_free(pathified);
9104 Newx(vmsified, VMS_MAXRSS, char);
9105 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
9106 PerlMem_free(pathified);
9107 if (vmsified) Safefree(vmsified);
9110 PerlMem_free(pathified);
9115 vmslen = strlen(vmsified);
9116 Newx(cp,vmslen+1,char);
9117 memcpy(cp,vmsified,vmslen);
9123 strcpy(__tovmspath_retbuf,vmsified);
9125 return __tovmspath_retbuf;
9128 } /* end of do_tovmspath() */
9130 /* External entry points */
9131 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
9132 { return do_tovmspath(path,buf,0, NULL); }
9133 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9134 { return do_tovmspath(path,buf,1, NULL); }
9135 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9136 { return do_tovmspath(path,buf,0,utf8_fl); }
9137 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9138 { return do_tovmspath(path,buf,1,utf8_fl); }
9141 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9142 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9143 static char __tounixpath_retbuf[VMS_MAXRSS];
9145 char *pathified, *unixified, *cp;
9147 if (path == NULL) return NULL;
9148 pathified = PerlMem_malloc(VMS_MAXRSS);
9149 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9150 if (int_pathify_dirspec(path, pathified) == NULL) {
9151 PerlMem_free(pathified);
9157 Newx(unixified, VMS_MAXRSS, char);
9159 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9160 PerlMem_free(pathified);
9161 if (unixified) Safefree(unixified);
9164 PerlMem_free(pathified);
9169 unixlen = strlen(unixified);
9170 Newx(cp,unixlen+1,char);
9171 memcpy(cp,unixified,unixlen);
9173 Safefree(unixified);
9177 strcpy(__tounixpath_retbuf,unixified);
9178 Safefree(unixified);
9179 return __tounixpath_retbuf;
9182 } /* end of do_tounixpath() */
9184 /* External entry points */
9185 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
9186 { return do_tounixpath(path,buf,0,NULL); }
9187 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9188 { return do_tounixpath(path,buf,1,NULL); }
9189 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9190 { return do_tounixpath(path,buf,0,utf8_fl); }
9191 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9192 { return do_tounixpath(path,buf,1,utf8_fl); }
9195 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
9197 *****************************************************************************
9199 * Copyright (C) 1989-1994, 2007 by *
9200 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
9202 * Permission is hereby granted for the reproduction of this software *
9203 * on condition that this copyright notice is included in source *
9204 * distributions of the software. The code may be modified and *
9205 * distributed under the same terms as Perl itself. *
9207 * 27-Aug-1994 Modified for inclusion in perl5 *
9208 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
9209 *****************************************************************************
9213 * getredirection() is intended to aid in porting C programs
9214 * to VMS (Vax-11 C). The native VMS environment does not support
9215 * '>' and '<' I/O redirection, or command line wild card expansion,
9216 * or a command line pipe mechanism using the '|' AND background
9217 * command execution '&'. All of these capabilities are provided to any
9218 * C program which calls this procedure as the first thing in the
9220 * The piping mechanism will probably work with almost any 'filter' type
9221 * of program. With suitable modification, it may useful for other
9222 * portability problems as well.
9224 * Author: Mark Pizzolato (mark AT infocomm DOT com)
9228 struct list_item *next;
9232 static void add_item(struct list_item **head,
9233 struct list_item **tail,
9237 static void mp_expand_wild_cards(pTHX_ char *item,
9238 struct list_item **head,
9239 struct list_item **tail,
9242 static int background_process(pTHX_ int argc, char **argv);
9244 static void pipe_and_fork(pTHX_ char **cmargv);
9246 /*{{{ void getredirection(int *ac, char ***av)*/
9248 mp_getredirection(pTHX_ int *ac, char ***av)
9250 * Process vms redirection arg's. Exit if any error is seen.
9251 * If getredirection() processes an argument, it is erased
9252 * from the vector. getredirection() returns a new argc and argv value.
9253 * In the event that a background command is requested (by a trailing "&"),
9254 * this routine creates a background subprocess, and simply exits the program.
9256 * Warning: do not try to simplify the code for vms. The code
9257 * presupposes that getredirection() is called before any data is
9258 * read from stdin or written to stdout.
9260 * Normal usage is as follows:
9266 * getredirection(&argc, &argv);
9270 int argc = *ac; /* Argument Count */
9271 char **argv = *av; /* Argument Vector */
9272 char *ap; /* Argument pointer */
9273 int j; /* argv[] index */
9274 int item_count = 0; /* Count of Items in List */
9275 struct list_item *list_head = 0; /* First Item in List */
9276 struct list_item *list_tail; /* Last Item in List */
9277 char *in = NULL; /* Input File Name */
9278 char *out = NULL; /* Output File Name */
9279 char *outmode = "w"; /* Mode to Open Output File */
9280 char *err = NULL; /* Error File Name */
9281 char *errmode = "w"; /* Mode to Open Error File */
9282 int cmargc = 0; /* Piped Command Arg Count */
9283 char **cmargv = NULL;/* Piped Command Arg Vector */
9286 * First handle the case where the last thing on the line ends with
9287 * a '&'. This indicates the desire for the command to be run in a
9288 * subprocess, so we satisfy that desire.
9291 if (0 == strcmp("&", ap))
9292 exit(background_process(aTHX_ --argc, argv));
9293 if (*ap && '&' == ap[strlen(ap)-1])
9295 ap[strlen(ap)-1] = '\0';
9296 exit(background_process(aTHX_ argc, argv));
9299 * Now we handle the general redirection cases that involve '>', '>>',
9300 * '<', and pipes '|'.
9302 for (j = 0; j < argc; ++j)
9304 if (0 == strcmp("<", argv[j]))
9308 fprintf(stderr,"No input file after < on command line");
9309 exit(LIB$_WRONUMARG);
9314 if ('<' == *(ap = argv[j]))
9319 if (0 == strcmp(">", ap))
9323 fprintf(stderr,"No output file after > on command line");
9324 exit(LIB$_WRONUMARG);
9343 fprintf(stderr,"No output file after > or >> on command line");
9344 exit(LIB$_WRONUMARG);
9348 if (('2' == *ap) && ('>' == ap[1]))
9365 fprintf(stderr,"No output file after 2> or 2>> on command line");
9366 exit(LIB$_WRONUMARG);
9370 if (0 == strcmp("|", argv[j]))
9374 fprintf(stderr,"No command into which to pipe on command line");
9375 exit(LIB$_WRONUMARG);
9377 cmargc = argc-(j+1);
9378 cmargv = &argv[j+1];
9382 if ('|' == *(ap = argv[j]))
9390 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9393 * Allocate and fill in the new argument vector, Some Unix's terminate
9394 * the list with an extra null pointer.
9396 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9397 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9399 for (j = 0; j < item_count; ++j, list_head = list_head->next)
9400 argv[j] = list_head->value;
9406 fprintf(stderr,"'|' and '>' may not both be specified on command line");
9407 exit(LIB$_INVARGORD);
9409 pipe_and_fork(aTHX_ cmargv);
9412 /* Check for input from a pipe (mailbox) */
9414 if (in == NULL && 1 == isapipe(0))
9416 char mbxname[L_tmpnam];
9418 long int dvi_item = DVI$_DEVBUFSIZ;
9419 $DESCRIPTOR(mbxnam, "");
9420 $DESCRIPTOR(mbxdevnam, "");
9422 /* Input from a pipe, reopen it in binary mode to disable */
9423 /* carriage control processing. */
9425 fgetname(stdin, mbxname, 1);
9426 mbxnam.dsc$a_pointer = mbxname;
9427 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9428 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9429 mbxdevnam.dsc$a_pointer = mbxname;
9430 mbxdevnam.dsc$w_length = sizeof(mbxname);
9431 dvi_item = DVI$_DEVNAM;
9432 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9433 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9436 freopen(mbxname, "rb", stdin);
9439 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9443 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9445 fprintf(stderr,"Can't open input file %s as stdin",in);
9448 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9450 fprintf(stderr,"Can't open output file %s as stdout",out);
9453 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9456 if (strcmp(err,"&1") == 0) {
9457 dup2(fileno(stdout), fileno(stderr));
9458 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9461 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9463 fprintf(stderr,"Can't open error file %s as stderr",err);
9467 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9471 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9474 #ifdef ARGPROC_DEBUG
9475 PerlIO_printf(Perl_debug_log, "Arglist:\n");
9476 for (j = 0; j < *ac; ++j)
9477 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9479 /* Clear errors we may have hit expanding wildcards, so they don't
9480 show up in Perl's $! later */
9481 set_errno(0); set_vaxc_errno(1);
9482 } /* end of getredirection() */
9485 static void add_item(struct list_item **head,
9486 struct list_item **tail,
9492 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9493 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9497 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9498 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9499 *tail = (*tail)->next;
9501 (*tail)->value = value;
9505 static void mp_expand_wild_cards(pTHX_ char *item,
9506 struct list_item **head,
9507 struct list_item **tail,
9511 unsigned long int context = 0;
9519 $DESCRIPTOR(filespec, "");
9520 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9521 $DESCRIPTOR(resultspec, "");
9522 unsigned long int lff_flags = 0;
9526 #ifdef VMS_LONGNAME_SUPPORT
9527 lff_flags = LIB$M_FIL_LONG_NAMES;
9530 for (cp = item; *cp; cp++) {
9531 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9532 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9534 if (!*cp || isspace(*cp))
9536 add_item(head, tail, item, count);
9541 /* "double quoted" wild card expressions pass as is */
9542 /* From DCL that means using e.g.: */
9543 /* perl program """perl.*""" */
9544 item_len = strlen(item);
9545 if ( '"' == *item && '"' == item[item_len-1] )
9548 item[item_len-2] = '\0';
9549 add_item(head, tail, item, count);
9553 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9554 resultspec.dsc$b_class = DSC$K_CLASS_D;
9555 resultspec.dsc$a_pointer = NULL;
9556 vmsspec = PerlMem_malloc(VMS_MAXRSS);
9557 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9558 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9559 filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9560 if (!isunix || !filespec.dsc$a_pointer)
9561 filespec.dsc$a_pointer = item;
9562 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9564 * Only return version specs, if the caller specified a version
9566 had_version = strchr(item, ';');
9568 * Only return device and directory specs, if the caller specifed either.
9570 had_device = strchr(item, ':');
9571 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9573 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9574 (&filespec, &resultspec, &context,
9575 &defaultspec, 0, &rms_sts, &lff_flags)))
9580 string = PerlMem_malloc(resultspec.dsc$w_length+1);
9581 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9582 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9583 string[resultspec.dsc$w_length] = '\0';
9584 if (NULL == had_version)
9585 *(strrchr(string, ';')) = '\0';
9586 if ((!had_directory) && (had_device == NULL))
9588 if (NULL == (devdir = strrchr(string, ']')))
9589 devdir = strrchr(string, '>');
9590 strcpy(string, devdir + 1);
9593 * Be consistent with what the C RTL has already done to the rest of
9594 * the argv items and lowercase all of these names.
9596 if (!decc_efs_case_preserve) {
9597 for (c = string; *c; ++c)
9601 if (isunix) trim_unixpath(string,item,1);
9602 add_item(head, tail, string, count);
9605 PerlMem_free(vmsspec);
9606 if (sts != RMS$_NMF)
9608 set_vaxc_errno(sts);
9611 case RMS$_FNF: case RMS$_DNF:
9612 set_errno(ENOENT); break;
9614 set_errno(ENOTDIR); break;
9616 set_errno(ENODEV); break;
9617 case RMS$_FNM: case RMS$_SYN:
9618 set_errno(EINVAL); break;
9620 set_errno(EACCES); break;
9622 _ckvmssts_noperl(sts);
9626 add_item(head, tail, item, count);
9627 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9628 _ckvmssts_noperl(lib$find_file_end(&context));
9631 static int child_st[2];/* Event Flag set when child process completes */
9633 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
9635 static unsigned long int exit_handler(int *status)
9639 if (0 == child_st[0])
9641 #ifdef ARGPROC_DEBUG
9642 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9644 fflush(stdout); /* Have to flush pipe for binary data to */
9645 /* terminate properly -- <tp@mccall.com> */
9646 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9647 sys$dassgn(child_chan);
9649 sys$synch(0, child_st);
9654 static void sig_child(int chan)
9656 #ifdef ARGPROC_DEBUG
9657 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9659 if (child_st[0] == 0)
9663 static struct exit_control_block exit_block =
9668 &exit_block.exit_status,
9673 pipe_and_fork(pTHX_ char **cmargv)
9676 struct dsc$descriptor_s *vmscmd;
9677 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9678 int sts, j, l, ismcr, quote, tquote = 0;
9680 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
9681 vms_execfree(vmscmd);
9686 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
9687 && toupper(*(q+2)) == 'R' && !*(q+3);
9689 while (q && l < MAX_DCL_LINE_LENGTH) {
9691 if (j > 0 && quote) {
9697 if (ismcr && j > 1) quote = 1;
9698 tquote = (strchr(q,' ')) != NULL || *q == '\0';
9701 if (quote || tquote) {
9707 if ((quote||tquote) && *q == '"') {
9717 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9719 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9723 static int background_process(pTHX_ int argc, char **argv)
9725 char command[MAX_DCL_SYMBOL + 1] = "$";
9726 $DESCRIPTOR(value, "");
9727 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9728 static $DESCRIPTOR(null, "NLA0:");
9729 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9731 $DESCRIPTOR(pidstr, "");
9733 unsigned long int flags = 17, one = 1, retsts;
9736 strcat(command, argv[0]);
9737 len = strlen(command);
9738 while (--argc && (len < MAX_DCL_SYMBOL))
9740 strcat(command, " \"");
9741 strcat(command, *(++argv));
9742 strcat(command, "\"");
9743 len = strlen(command);
9745 value.dsc$a_pointer = command;
9746 value.dsc$w_length = strlen(value.dsc$a_pointer);
9747 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9748 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9749 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9750 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9753 _ckvmssts_noperl(retsts);
9755 #ifdef ARGPROC_DEBUG
9756 PerlIO_printf(Perl_debug_log, "%s\n", command);
9758 sprintf(pidstring, "%08X", pid);
9759 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9760 pidstr.dsc$a_pointer = pidstring;
9761 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9762 lib$set_symbol(&pidsymbol, &pidstr);
9766 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9769 /* OS-specific initialization at image activation (not thread startup) */
9770 /* Older VAXC header files lack these constants */
9771 #ifndef JPI$_RIGHTS_SIZE
9772 # define JPI$_RIGHTS_SIZE 817
9774 #ifndef KGB$M_SUBSYSTEM
9775 # define KGB$M_SUBSYSTEM 0x8
9778 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9780 /*{{{void vms_image_init(int *, char ***)*/
9782 vms_image_init(int *argcp, char ***argvp)
9785 char eqv[LNM$C_NAMLENGTH+1] = "";
9786 unsigned int len, tabct = 8, tabidx = 0;
9787 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9788 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9789 unsigned short int dummy, rlen;
9790 struct dsc$descriptor_s **tabvec;
9791 #if defined(PERL_IMPLICIT_CONTEXT)
9794 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
9795 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
9796 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9799 #ifdef KILL_BY_SIGPRC
9800 Perl_csighandler_init();
9803 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9804 /* This was moved from the pre-image init handler because on threaded */
9805 /* Perl it was always returning 0 for the default value. */
9806 status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9809 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9812 initial = decc$feature_get_value(s, 4);
9814 /* initial is: 0 if nothing has set the feature */
9815 /* -1 if initialized to default */
9816 /* 1 if set by logical name */
9817 /* 2 if set by decc$feature_set_value */
9818 decc_disable_posix_root = decc$feature_get_value(s, 1);
9820 /* If the value is not valid, force the feature off */
9821 if (decc_disable_posix_root < 0) {
9822 decc$feature_set_value(s, 1, 1);
9823 decc_disable_posix_root = 1;
9827 /* Nothing has asked for it explicitly, so use our own default. */
9828 decc_disable_posix_root = 1;
9829 decc$feature_set_value(s, 1, 1);
9835 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9836 _ckvmssts_noperl(iosb[0]);
9837 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9838 if (iprv[i]) { /* Running image installed with privs? */
9839 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
9844 /* Rights identifiers might trigger tainting as well. */
9845 if (!will_taint && (rlen || rsz)) {
9846 while (rlen < rsz) {
9847 /* We didn't get all the identifiers on the first pass. Allocate a
9848 * buffer much larger than $GETJPI wants (rsz is size in bytes that
9849 * were needed to hold all identifiers at time of last call; we'll
9850 * allocate that many unsigned long ints), and go back and get 'em.
9851 * If it gave us less than it wanted to despite ample buffer space,
9852 * something's broken. Is your system missing a system identifier?
9854 if (rsz <= jpilist[1].buflen) {
9855 /* Perl_croak accvios when used this early in startup. */
9856 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9857 rsz, (unsigned long) jpilist[1].buflen,
9858 "Check your rights database for corruption.\n");
9861 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9862 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9863 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9864 jpilist[1].buflen = rsz * sizeof(unsigned long int);
9865 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9866 _ckvmssts_noperl(iosb[0]);
9868 mask = jpilist[1].bufadr;
9869 /* Check attribute flags for each identifier (2nd longword); protected
9870 * subsystem identifiers trigger tainting.
9872 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9873 if (mask[i] & KGB$M_SUBSYSTEM) {
9878 if (mask != rlst) PerlMem_free(mask);
9881 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9882 * logical, some versions of the CRTL will add a phanthom /000000/
9883 * directory. This needs to be removed.
9885 if (decc_filename_unix_report) {
9888 ulen = strlen(argvp[0][0]);
9890 zeros = strstr(argvp[0][0], "/000000/");
9891 if (zeros != NULL) {
9893 mlen = ulen - (zeros - argvp[0][0]) - 7;
9894 memmove(zeros, &zeros[7], mlen);
9896 argvp[0][0][ulen] = '\0';
9899 /* It also may have a trailing dot that needs to be removed otherwise
9900 * it will be converted to VMS mode incorrectly.
9903 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9904 argvp[0][0][ulen] = '\0';
9907 /* We need to use this hack to tell Perl it should run with tainting,
9908 * since its tainting flag may be part of the PL_curinterp struct, which
9909 * hasn't been allocated when vms_image_init() is called.
9912 char **newargv, **oldargv;
9914 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9915 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9916 newargv[0] = oldargv[0];
9917 newargv[1] = PerlMem_malloc(3 * sizeof(char));
9918 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9919 strcpy(newargv[1], "-T");
9920 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9922 newargv[*argcp] = NULL;
9923 /* We orphan the old argv, since we don't know where it's come from,
9924 * so we don't know how to free it.
9928 else { /* Did user explicitly request tainting? */
9930 char *cp, **av = *argvp;
9931 for (i = 1; i < *argcp; i++) {
9932 if (*av[i] != '-') break;
9933 for (cp = av[i]+1; *cp; cp++) {
9934 if (*cp == 'T') { will_taint = 1; break; }
9935 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9936 strchr("DFIiMmx",*cp)) break;
9938 if (will_taint) break;
9943 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9946 tabvec = (struct dsc$descriptor_s **)
9947 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9948 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9950 else if (tabidx >= tabct) {
9952 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9953 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9955 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9956 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9957 tabvec[tabidx]->dsc$w_length = 0;
9958 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9959 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9960 tabvec[tabidx]->dsc$a_pointer = NULL;
9961 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9963 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9965 getredirection(argcp,argvp);
9966 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9968 # include <reentrancy.h>
9969 decc$set_reentrancy(C$C_MULTITHREAD);
9978 * Trim Unix-style prefix off filespec, so it looks like what a shell
9979 * glob expansion would return (i.e. from specified prefix on, not
9980 * full path). Note that returned filespec is Unix-style, regardless
9981 * of whether input filespec was VMS-style or Unix-style.
9983 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9984 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9985 * vector of options; at present, only bit 0 is used, and if set tells
9986 * trim unixpath to try the current default directory as a prefix when
9987 * presented with a possibly ambiguous ... wildcard.
9989 * Returns !=0 on success, with trimmed filespec replacing contents of
9990 * fspec, and 0 on failure, with contents of fpsec unchanged.
9992 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9994 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9996 char *unixified, *unixwild,
9997 *template, *base, *end, *cp1, *cp2;
9998 register int tmplen, reslen = 0, dirs = 0;
10000 if (!wildspec || !fspec) return 0;
10002 unixwild = PerlMem_malloc(VMS_MAXRSS);
10003 if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10004 template = unixwild;
10005 if (strpbrk(wildspec,"]>:") != NULL) {
10006 if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
10007 PerlMem_free(unixwild);
10012 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
10013 unixwild[VMS_MAXRSS-1] = 0;
10015 unixified = PerlMem_malloc(VMS_MAXRSS);
10016 if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10017 if (strpbrk(fspec,"]>:") != NULL) {
10018 if (int_tounixspec(fspec, unixified, NULL) == NULL) {
10019 PerlMem_free(unixwild);
10020 PerlMem_free(unixified);
10023 else base = unixified;
10024 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
10025 * check to see that final result fits into (isn't longer than) fspec */
10026 reslen = strlen(fspec);
10030 /* No prefix or absolute path on wildcard, so nothing to remove */
10031 if (!*template || *template == '/') {
10032 PerlMem_free(unixwild);
10033 if (base == fspec) {
10034 PerlMem_free(unixified);
10037 tmplen = strlen(unixified);
10038 if (tmplen > reslen) {
10039 PerlMem_free(unixified);
10040 return 0; /* not enough space */
10042 /* Copy unixified resultant, including trailing NUL */
10043 memmove(fspec,unixified,tmplen+1);
10044 PerlMem_free(unixified);
10048 for (end = base; *end; end++) ; /* Find end of resultant filespec */
10049 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
10050 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
10051 for (cp1 = end ;cp1 >= base; cp1--)
10052 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
10054 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
10055 PerlMem_free(unixified);
10056 PerlMem_free(unixwild);
10061 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
10062 int ells = 1, totells, segdirs, match;
10063 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
10064 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10066 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
10068 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
10069 tpl = PerlMem_malloc(VMS_MAXRSS);
10070 if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10071 if (ellipsis == template && opts & 1) {
10072 /* Template begins with an ellipsis. Since we can't tell how many
10073 * directory names at the front of the resultant to keep for an
10074 * arbitrary starting point, we arbitrarily choose the current
10075 * default directory as a starting point. If it's there as a prefix,
10076 * clip it off. If not, fall through and act as if the leading
10077 * ellipsis weren't there (i.e. return shortest possible path that
10078 * could match template).
10080 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
10082 PerlMem_free(unixified);
10083 PerlMem_free(unixwild);
10086 if (!decc_efs_case_preserve) {
10087 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10088 if (_tolower(*cp1) != _tolower(*cp2)) break;
10090 segdirs = dirs - totells; /* Min # of dirs we must have left */
10091 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
10092 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
10093 memmove(fspec,cp2+1,end - cp2);
10095 PerlMem_free(unixified);
10096 PerlMem_free(unixwild);
10100 /* First off, back up over constant elements at end of path */
10102 for (front = end ; front >= base; front--)
10103 if (*front == '/' && !dirs--) { front++; break; }
10105 lcres = PerlMem_malloc(VMS_MAXRSS);
10106 if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10107 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
10109 if (!decc_efs_case_preserve) {
10110 *cp2 = _tolower(*cp1); /* Make lc copy for match */
10118 PerlMem_free(unixified);
10119 PerlMem_free(unixwild);
10120 PerlMem_free(lcres);
10121 return 0; /* Path too long. */
10124 *cp2 = '\0'; /* Pick up with memcpy later */
10125 lcfront = lcres + (front - base);
10126 /* Now skip over each ellipsis and try to match the path in front of it. */
10128 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
10129 if (*(cp1) == '.' && *(cp1+1) == '.' &&
10130 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
10131 if (cp1 < template) break; /* template started with an ellipsis */
10132 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
10133 ellipsis = cp1; continue;
10135 wilddsc.dsc$a_pointer = tpl;
10136 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
10138 for (segdirs = 0, cp2 = tpl;
10139 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
10141 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
10143 if (!decc_efs_case_preserve) {
10144 *cp2 = _tolower(*cp1); /* else lowercase for match */
10147 *cp2 = *cp1; /* else preserve case for match */
10150 if (*cp2 == '/') segdirs++;
10152 if (cp1 != ellipsis - 1) {
10154 PerlMem_free(unixified);
10155 PerlMem_free(unixwild);
10156 PerlMem_free(lcres);
10157 return 0; /* Path too long */
10159 /* Back up at least as many dirs as in template before matching */
10160 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10161 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10162 for (match = 0; cp1 > lcres;) {
10163 resdsc.dsc$a_pointer = cp1;
10164 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10166 if (match == 1) lcfront = cp1;
10168 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10172 PerlMem_free(unixified);
10173 PerlMem_free(unixwild);
10174 PerlMem_free(lcres);
10175 return 0; /* Can't find prefix ??? */
10177 if (match > 1 && opts & 1) {
10178 /* This ... wildcard could cover more than one set of dirs (i.e.
10179 * a set of similar dir names is repeated). If the template
10180 * contains more than 1 ..., upstream elements could resolve the
10181 * ambiguity, but it's not worth a full backtracking setup here.
10182 * As a quick heuristic, clip off the current default directory
10183 * if it's present to find the trimmed spec, else use the
10184 * shortest string that this ... could cover.
10186 char def[NAM$C_MAXRSS+1], *st;
10188 if (getcwd(def, sizeof def,0) == NULL) {
10189 PerlMem_free(unixified);
10190 PerlMem_free(unixwild);
10191 PerlMem_free(lcres);
10195 if (!decc_efs_case_preserve) {
10196 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10197 if (_tolower(*cp1) != _tolower(*cp2)) break;
10199 segdirs = dirs - totells; /* Min # of dirs we must have left */
10200 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10201 if (*cp1 == '\0' && *cp2 == '/') {
10202 memmove(fspec,cp2+1,end - cp2);
10204 PerlMem_free(unixified);
10205 PerlMem_free(unixwild);
10206 PerlMem_free(lcres);
10209 /* Nope -- stick with lcfront from above and keep going. */
10212 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10214 PerlMem_free(unixified);
10215 PerlMem_free(unixwild);
10216 PerlMem_free(lcres);
10218 ellipsis = nextell;
10221 } /* end of trim_unixpath() */
10226 * VMS readdir() routines.
10227 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10229 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
10230 * Minor modifications to original routines.
10233 /* readdir may have been redefined by reentr.h, so make sure we get
10234 * the local version for what we do here.
10239 #if !defined(PERL_IMPLICIT_CONTEXT)
10240 # define readdir Perl_readdir
10242 # define readdir(a) Perl_readdir(aTHX_ a)
10245 /* Number of elements in vms_versions array */
10246 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
10249 * Open a directory, return a handle for later use.
10251 /*{{{ DIR *opendir(char*name) */
10253 Perl_opendir(pTHX_ const char *name)
10259 Newx(dir, VMS_MAXRSS, char);
10260 if (int_tovmspath(name, dir, NULL) == NULL) {
10264 /* Check access before stat; otherwise stat does not
10265 * accurately report whether it's a directory.
10267 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10268 /* cando_by_name has already set errno */
10272 if (flex_stat(dir,&sb) == -1) return NULL;
10273 if (!S_ISDIR(sb.st_mode)) {
10275 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
10278 /* Get memory for the handle, and the pattern. */
10280 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10282 /* Fill in the fields; mainly playing with the descriptor. */
10283 sprintf(dd->pattern, "%s*.*",dir);
10288 /* By saying we always want the result of readdir() in unix format, we
10289 * are really saying we want all the escapes removed. Otherwise the caller,
10290 * having no way to know whether it's already in VMS format, might send it
10291 * through tovmsspec again, thus double escaping.
10293 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10294 dd->pat.dsc$a_pointer = dd->pattern;
10295 dd->pat.dsc$w_length = strlen(dd->pattern);
10296 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10297 dd->pat.dsc$b_class = DSC$K_CLASS_S;
10298 #if defined(USE_ITHREADS)
10299 Newx(dd->mutex,1,perl_mutex);
10300 MUTEX_INIT( (perl_mutex *) dd->mutex );
10306 } /* end of opendir() */
10310 * Set the flag to indicate we want versions or not.
10312 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10314 vmsreaddirversions(DIR *dd, int flag)
10317 dd->flags |= PERL_VMSDIR_M_VERSIONS;
10319 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10324 * Free up an opened directory.
10326 /*{{{ void closedir(DIR *dd)*/
10328 Perl_closedir(DIR *dd)
10332 sts = lib$find_file_end(&dd->context);
10333 Safefree(dd->pattern);
10334 #if defined(USE_ITHREADS)
10335 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10336 Safefree(dd->mutex);
10343 * Collect all the version numbers for the current file.
10346 collectversions(pTHX_ DIR *dd)
10348 struct dsc$descriptor_s pat;
10349 struct dsc$descriptor_s res;
10351 char *p, *text, *buff;
10353 unsigned long context, tmpsts;
10355 /* Convenient shorthand. */
10358 /* Add the version wildcard, ignoring the "*.*" put on before */
10359 i = strlen(dd->pattern);
10360 Newx(text,i + e->d_namlen + 3,char);
10361 strcpy(text, dd->pattern);
10362 sprintf(&text[i - 3], "%s;*", e->d_name);
10364 /* Set up the pattern descriptor. */
10365 pat.dsc$a_pointer = text;
10366 pat.dsc$w_length = i + e->d_namlen - 1;
10367 pat.dsc$b_dtype = DSC$K_DTYPE_T;
10368 pat.dsc$b_class = DSC$K_CLASS_S;
10370 /* Set up result descriptor. */
10371 Newx(buff, VMS_MAXRSS, char);
10372 res.dsc$a_pointer = buff;
10373 res.dsc$w_length = VMS_MAXRSS - 1;
10374 res.dsc$b_dtype = DSC$K_DTYPE_T;
10375 res.dsc$b_class = DSC$K_CLASS_S;
10377 /* Read files, collecting versions. */
10378 for (context = 0, e->vms_verscount = 0;
10379 e->vms_verscount < VERSIZE(e);
10380 e->vms_verscount++) {
10381 unsigned long rsts;
10382 unsigned long flags = 0;
10384 #ifdef VMS_LONGNAME_SUPPORT
10385 flags = LIB$M_FIL_LONG_NAMES;
10387 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10388 if (tmpsts == RMS$_NMF || context == 0) break;
10390 buff[VMS_MAXRSS - 1] = '\0';
10391 if ((p = strchr(buff, ';')))
10392 e->vms_versions[e->vms_verscount] = atoi(p + 1);
10394 e->vms_versions[e->vms_verscount] = -1;
10397 _ckvmssts(lib$find_file_end(&context));
10401 } /* end of collectversions() */
10404 * Read the next entry from the directory.
10406 /*{{{ struct dirent *readdir(DIR *dd)*/
10408 Perl_readdir(pTHX_ DIR *dd)
10410 struct dsc$descriptor_s res;
10412 unsigned long int tmpsts;
10413 unsigned long rsts;
10414 unsigned long flags = 0;
10415 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10416 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10418 /* Set up result descriptor, and get next file. */
10419 Newx(buff, VMS_MAXRSS, char);
10420 res.dsc$a_pointer = buff;
10421 res.dsc$w_length = VMS_MAXRSS - 1;
10422 res.dsc$b_dtype = DSC$K_DTYPE_T;
10423 res.dsc$b_class = DSC$K_CLASS_S;
10425 #ifdef VMS_LONGNAME_SUPPORT
10426 flags = LIB$M_FIL_LONG_NAMES;
10429 tmpsts = lib$find_file
10430 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10431 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
10432 if (!(tmpsts & 1)) {
10433 set_vaxc_errno(tmpsts);
10436 set_errno(EACCES); break;
10438 set_errno(ENODEV); break;
10440 set_errno(ENOTDIR); break;
10441 case RMS$_FNF: case RMS$_DNF:
10442 set_errno(ENOENT); break;
10444 set_errno(EVMSERR);
10450 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10451 buff[res.dsc$w_length] = '\0';
10452 p = buff + res.dsc$w_length;
10453 while (--p >= buff) if (!isspace(*p)) break;
10455 if (!decc_efs_case_preserve) {
10456 for (p = buff; *p; p++) *p = _tolower(*p);
10459 /* Skip any directory component and just copy the name. */
10460 sts = vms_split_path
10475 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10477 /* In Unix report mode, remove the ".dir;1" from the name */
10478 /* if it is a real directory. */
10479 if (decc_filename_unix_report || decc_efs_charset) {
10480 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10484 ret_sts = flex_lstat(buff, &statbuf);
10485 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10492 /* Drop NULL extensions on UNIX file specification */
10493 if ((e_len == 1) && decc_readdir_dropdotnotype) {
10499 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10500 dd->entry.d_name[n_len + e_len] = '\0';
10501 dd->entry.d_namlen = strlen(dd->entry.d_name);
10503 /* Convert the filename to UNIX format if needed */
10504 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10506 /* Translate the encoded characters. */
10507 /* Fixme: Unicode handling could result in embedded 0 characters */
10508 if (strchr(dd->entry.d_name, '^') != NULL) {
10509 char new_name[256];
10511 p = dd->entry.d_name;
10514 int inchars_read, outchars_added;
10515 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10517 q += outchars_added;
10519 /* if outchars_added > 1, then this is a wide file specification */
10520 /* Wide file specifications need to be passed in Perl */
10521 /* counted strings apparently with a Unicode flag */
10524 strcpy(dd->entry.d_name, new_name);
10525 dd->entry.d_namlen = strlen(dd->entry.d_name);
10529 dd->entry.vms_verscount = 0;
10530 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10534 } /* end of readdir() */
10538 * Read the next entry from the directory -- thread-safe version.
10540 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10542 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10546 MUTEX_LOCK( (perl_mutex *) dd->mutex );
10548 entry = readdir(dd);
10550 retval = ( *result == NULL ? errno : 0 );
10552 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10556 } /* end of readdir_r() */
10560 * Return something that can be used in a seekdir later.
10562 /*{{{ long telldir(DIR *dd)*/
10564 Perl_telldir(DIR *dd)
10571 * Return to a spot where we used to be. Brute force.
10573 /*{{{ void seekdir(DIR *dd,long count)*/
10575 Perl_seekdir(pTHX_ DIR *dd, long count)
10579 /* If we haven't done anything yet... */
10580 if (dd->count == 0)
10583 /* Remember some state, and clear it. */
10584 old_flags = dd->flags;
10585 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10586 _ckvmssts(lib$find_file_end(&dd->context));
10589 /* The increment is in readdir(). */
10590 for (dd->count = 0; dd->count < count; )
10593 dd->flags = old_flags;
10595 } /* end of seekdir() */
10598 /* VMS subprocess management
10600 * my_vfork() - just a vfork(), after setting a flag to record that
10601 * the current script is trying a Unix-style fork/exec.
10603 * vms_do_aexec() and vms_do_exec() are called in response to the
10604 * perl 'exec' function. If this follows a vfork call, then they
10605 * call out the regular perl routines in doio.c which do an
10606 * execvp (for those who really want to try this under VMS).
10607 * Otherwise, they do exactly what the perl docs say exec should
10608 * do - terminate the current script and invoke a new command
10609 * (See below for notes on command syntax.)
10611 * do_aspawn() and do_spawn() implement the VMS side of the perl
10612 * 'system' function.
10614 * Note on command arguments to perl 'exec' and 'system': When handled
10615 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10616 * are concatenated to form a DCL command string. If the first non-numeric
10617 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10618 * the command string is handed off to DCL directly. Otherwise,
10619 * the first token of the command is taken as the filespec of an image
10620 * to run. The filespec is expanded using a default type of '.EXE' and
10621 * the process defaults for device, directory, etc., and if found, the resultant
10622 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10623 * the command string as parameters. This is perhaps a bit complicated,
10624 * but I hope it will form a happy medium between what VMS folks expect
10625 * from lib$spawn and what Unix folks expect from exec.
10628 static int vfork_called;
10630 /*{{{int my_vfork()*/
10641 vms_execfree(struct dsc$descriptor_s *vmscmd)
10644 if (vmscmd->dsc$a_pointer) {
10645 PerlMem_free(vmscmd->dsc$a_pointer);
10647 PerlMem_free(vmscmd);
10652 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10654 char *junk, *tmps = NULL;
10655 register size_t cmdlen = 0;
10662 tmps = SvPV(really,rlen);
10664 cmdlen += rlen + 1;
10669 for (idx++; idx <= sp; idx++) {
10671 junk = SvPVx(*idx,rlen);
10672 cmdlen += rlen ? rlen + 1 : 0;
10675 Newx(PL_Cmd, cmdlen+1, char);
10677 if (tmps && *tmps) {
10678 strcpy(PL_Cmd,tmps);
10681 else *PL_Cmd = '\0';
10682 while (++mark <= sp) {
10684 char *s = SvPVx(*mark,n_a);
10686 if (*PL_Cmd) strcat(PL_Cmd," ");
10692 } /* end of setup_argstr() */
10695 static unsigned long int
10696 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10697 struct dsc$descriptor_s **pvmscmd)
10701 char image_name[NAM$C_MAXRSS+1];
10702 char image_argv[NAM$C_MAXRSS+1];
10703 $DESCRIPTOR(defdsc,".EXE");
10704 $DESCRIPTOR(defdsc2,".");
10705 struct dsc$descriptor_s resdsc;
10706 struct dsc$descriptor_s *vmscmd;
10707 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10708 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10709 register char *s, *rest, *cp, *wordbreak;
10712 register int isdcl;
10714 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10715 if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10717 /* vmsspec is a DCL command buffer, not just a filename */
10718 vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10719 if (vmsspec == NULL)
10720 _ckvmssts_noperl(SS$_INSFMEM);
10722 resspec = PerlMem_malloc(VMS_MAXRSS);
10723 if (resspec == NULL)
10724 _ckvmssts_noperl(SS$_INSFMEM);
10726 /* Make a copy for modification */
10727 cmdlen = strlen(incmd);
10728 cmd = PerlMem_malloc(cmdlen+1);
10729 if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10730 strncpy(cmd, incmd, cmdlen);
10735 resdsc.dsc$a_pointer = resspec;
10736 resdsc.dsc$b_dtype = DSC$K_DTYPE_T;
10737 resdsc.dsc$b_class = DSC$K_CLASS_S;
10738 resdsc.dsc$w_length = VMS_MAXRSS - 1;
10740 vmscmd->dsc$a_pointer = NULL;
10741 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
10742 vmscmd->dsc$b_class = DSC$K_CLASS_S;
10743 vmscmd->dsc$w_length = 0;
10744 if (pvmscmd) *pvmscmd = vmscmd;
10746 if (suggest_quote) *suggest_quote = 0;
10748 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10750 PerlMem_free(vmsspec);
10751 PerlMem_free(resspec);
10752 return CLI$_BUFOVF; /* continuation lines currently unsupported */
10757 while (*s && isspace(*s)) s++;
10759 if (*s == '@' || *s == '$') {
10760 vmsspec[0] = *s; rest = s + 1;
10761 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10763 else { cp = vmsspec; rest = s; }
10764 if (*rest == '.' || *rest == '/') {
10766 for (cp2 = resspec;
10767 *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10768 rest++, cp2++) *cp2 = *rest;
10770 if (int_tovmsspec(resspec, cp, 0, NULL)) {
10773 /* When a UNIX spec with no file type is translated to VMS, */
10774 /* A trailing '.' is appended under ODS-5 rules. */
10775 /* Here we do not want that trailing "." as it prevents */
10776 /* Looking for a implied ".exe" type. */
10777 if (decc_efs_charset) {
10779 i = strlen(vmsspec);
10780 if (vmsspec[i-1] == '.') {
10781 vmsspec[i-1] = '\0';
10786 for (cp2 = vmsspec + strlen(vmsspec);
10787 *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10788 rest++, cp2++) *cp2 = *rest;
10793 /* Intuit whether verb (first word of cmd) is a DCL command:
10794 * - if first nonspace char is '@', it's a DCL indirection
10796 * - if verb contains a filespec separator, it's not a DCL command
10797 * - if it doesn't, caller tells us whether to default to a DCL
10798 * command, or to a local image unless told it's DCL (by leading '$')
10802 if (suggest_quote) *suggest_quote = 1;
10804 register char *filespec = strpbrk(s,":<[.;");
10805 rest = wordbreak = strpbrk(s," \"\t/");
10806 if (!wordbreak) wordbreak = s + strlen(s);
10807 if (*s == '$') check_img = 0;
10808 if (filespec && (filespec < wordbreak)) isdcl = 0;
10809 else isdcl = !check_img;
10814 imgdsc.dsc$a_pointer = s;
10815 imgdsc.dsc$w_length = wordbreak - s;
10816 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10818 _ckvmssts_noperl(lib$find_file_end(&cxt));
10819 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10820 if (!(retsts & 1) && *s == '$') {
10821 _ckvmssts_noperl(lib$find_file_end(&cxt));
10822 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10823 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10825 _ckvmssts_noperl(lib$find_file_end(&cxt));
10826 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10830 _ckvmssts_noperl(lib$find_file_end(&cxt));
10835 while (*s && !isspace(*s)) s++;
10838 /* check that it's really not DCL with no file extension */
10839 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10841 char b[256] = {0,0,0,0};
10842 read(fileno(fp), b, 256);
10843 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10847 /* Check for script */
10849 if ((b[0] == '#') && (b[1] == '!'))
10851 #ifdef ALTERNATE_SHEBANG
10853 shebang_len = strlen(ALTERNATE_SHEBANG);
10854 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10856 perlstr = strstr("perl",b);
10857 if (perlstr == NULL)
10865 if (shebang_len > 0) {
10868 char tmpspec[NAM$C_MAXRSS + 1];
10871 /* Image is following after white space */
10872 /*--------------------------------------*/
10873 while (isprint(b[i]) && isspace(b[i]))
10877 while (isprint(b[i]) && !isspace(b[i])) {
10878 tmpspec[j++] = b[i++];
10879 if (j >= NAM$C_MAXRSS)
10884 /* There may be some default parameters to the image */
10885 /*---------------------------------------------------*/
10887 while (isprint(b[i])) {
10888 image_argv[j++] = b[i++];
10889 if (j >= NAM$C_MAXRSS)
10892 while ((j > 0) && !isprint(image_argv[j-1]))
10896 /* It will need to be converted to VMS format and validated */
10897 if (tmpspec[0] != '\0') {
10900 /* Try to find the exact program requested to be run */
10901 /*---------------------------------------------------*/
10902 iname = int_rmsexpand
10903 (tmpspec, image_name, ".exe",
10904 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10905 if (iname != NULL) {
10906 if (cando_by_name_int
10907 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10908 /* MCR prefix needed */
10912 /* Try again with a null type */
10913 /*----------------------------*/
10914 iname = int_rmsexpand
10915 (tmpspec, image_name, ".",
10916 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10917 if (iname != NULL) {
10918 if (cando_by_name_int
10919 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10920 /* MCR prefix needed */
10926 /* Did we find the image to run the script? */
10927 /*------------------------------------------*/
10931 /* Assume DCL or foreign command exists */
10932 /*--------------------------------------*/
10933 tchr = strrchr(tmpspec, '/');
10934 if (tchr != NULL) {
10940 strcpy(image_name, tchr);
10948 if (check_img && isdcl) {
10950 PerlMem_free(resspec);
10951 PerlMem_free(vmsspec);
10955 if (cando_by_name(S_IXUSR,0,resspec)) {
10956 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10957 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10959 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10960 if (image_name[0] != 0) {
10961 strcat(vmscmd->dsc$a_pointer, image_name);
10962 strcat(vmscmd->dsc$a_pointer, " ");
10964 } else if (image_name[0] != 0) {
10965 strcpy(vmscmd->dsc$a_pointer, image_name);
10966 strcat(vmscmd->dsc$a_pointer, " ");
10968 strcpy(vmscmd->dsc$a_pointer,"@");
10970 if (suggest_quote) *suggest_quote = 1;
10972 /* If there is an image name, use original command */
10973 if (image_name[0] == 0)
10974 strcat(vmscmd->dsc$a_pointer,resspec);
10977 while (*rest && isspace(*rest)) rest++;
10980 if (image_argv[0] != 0) {
10981 strcat(vmscmd->dsc$a_pointer,image_argv);
10982 strcat(vmscmd->dsc$a_pointer, " ");
10988 rest_len = strlen(rest);
10989 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10990 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10991 strcat(vmscmd->dsc$a_pointer,rest);
10993 retsts = CLI$_BUFOVF;
10995 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10997 PerlMem_free(vmsspec);
10998 PerlMem_free(resspec);
10999 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
11005 /* It's either a DCL command or we couldn't find a suitable image */
11006 vmscmd->dsc$w_length = strlen(cmd);
11008 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
11009 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
11010 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
11013 PerlMem_free(resspec);
11014 PerlMem_free(vmsspec);
11016 /* check if it's a symbol (for quoting purposes) */
11017 if (suggest_quote && !*suggest_quote) {
11019 char equiv[LNM$C_NAMLENGTH];
11020 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11021 eqvdsc.dsc$a_pointer = equiv;
11023 iss = lib$get_symbol(vmscmd,&eqvdsc);
11024 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
11026 if (!(retsts & 1)) {
11027 /* just hand off status values likely to be due to user error */
11028 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
11029 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
11030 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
11031 else { _ckvmssts_noperl(retsts); }
11034 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
11036 } /* end of setup_cmddsc() */
11039 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
11041 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
11047 if (vfork_called) { /* this follows a vfork - act Unixish */
11049 if (vfork_called < 0) {
11050 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11053 else return do_aexec(really,mark,sp);
11055 /* no vfork - act VMSish */
11056 cmd = setup_argstr(aTHX_ really,mark,sp);
11057 exec_sts = vms_do_exec(cmd);
11058 Safefree(cmd); /* Clean up from setup_argstr() */
11063 } /* end of vms_do_aexec() */
11066 /* {{{bool vms_do_exec(char *cmd) */
11068 Perl_vms_do_exec(pTHX_ const char *cmd)
11070 struct dsc$descriptor_s *vmscmd;
11072 if (vfork_called) { /* this follows a vfork - act Unixish */
11074 if (vfork_called < 0) {
11075 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11078 else return do_exec(cmd);
11081 { /* no vfork - act VMSish */
11082 unsigned long int retsts;
11085 TAINT_PROPER("exec");
11086 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
11087 retsts = lib$do_command(vmscmd);
11090 case RMS$_FNF: case RMS$_DNF:
11091 set_errno(ENOENT); break;
11093 set_errno(ENOTDIR); break;
11095 set_errno(ENODEV); break;
11097 set_errno(EACCES); break;
11099 set_errno(EINVAL); break;
11100 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11101 set_errno(E2BIG); break;
11102 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11103 _ckvmssts_noperl(retsts); /* fall through */
11104 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11105 set_errno(EVMSERR);
11107 set_vaxc_errno(retsts);
11108 if (ckWARN(WARN_EXEC)) {
11109 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
11110 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
11112 vms_execfree(vmscmd);
11117 } /* end of vms_do_exec() */
11120 int do_spawn2(pTHX_ const char *, int);
11123 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11125 unsigned long int sts;
11131 /* We'll copy the (undocumented?) Win32 behavior and allow a
11132 * numeric first argument. But the only value we'll support
11133 * through do_aspawn is a value of 1, which means spawn without
11134 * waiting for completion -- other values are ignored.
11136 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11138 flags = SvIVx(*mark);
11141 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
11142 flags = CLI$M_NOWAIT;
11146 cmd = setup_argstr(aTHX_ really, mark, sp);
11147 sts = do_spawn2(aTHX_ cmd, flags);
11148 /* pp_sys will clean up cmd */
11152 } /* end of do_aspawn() */
11156 /* {{{int do_spawn(char* cmd) */
11158 Perl_do_spawn(pTHX_ char* cmd)
11160 PERL_ARGS_ASSERT_DO_SPAWN;
11162 return do_spawn2(aTHX_ cmd, 0);
11166 /* {{{int do_spawn_nowait(char* cmd) */
11168 Perl_do_spawn_nowait(pTHX_ char* cmd)
11170 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11172 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11176 /* {{{int do_spawn2(char *cmd) */
11178 do_spawn2(pTHX_ const char *cmd, int flags)
11180 unsigned long int sts, substs;
11182 /* The caller of this routine expects to Safefree(PL_Cmd) */
11183 Newx(PL_Cmd,10,char);
11186 TAINT_PROPER("spawn");
11187 if (!cmd || !*cmd) {
11188 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11191 case RMS$_FNF: case RMS$_DNF:
11192 set_errno(ENOENT); break;
11194 set_errno(ENOTDIR); break;
11196 set_errno(ENODEV); break;
11198 set_errno(EACCES); break;
11200 set_errno(EINVAL); break;
11201 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11202 set_errno(E2BIG); break;
11203 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11204 _ckvmssts_noperl(sts); /* fall through */
11205 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11206 set_errno(EVMSERR);
11208 set_vaxc_errno(sts);
11209 if (ckWARN(WARN_EXEC)) {
11210 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11219 if (flags & CLI$M_NOWAIT)
11222 strcpy(mode, "nW");
11224 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11227 /* sts will be the pid in the nowait case */
11230 } /* end of do_spawn2() */
11234 static unsigned int *sockflags, sockflagsize;
11237 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11238 * routines found in some versions of the CRTL can't deal with sockets.
11239 * We don't shim the other file open routines since a socket isn't
11240 * likely to be opened by a name.
11242 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11243 FILE *my_fdopen(int fd, const char *mode)
11245 FILE *fp = fdopen(fd, mode);
11248 unsigned int fdoff = fd / sizeof(unsigned int);
11249 Stat_t sbuf; /* native stat; we don't need flex_stat */
11250 if (!sockflagsize || fdoff > sockflagsize) {
11251 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
11252 else Newx (sockflags,fdoff+2,unsigned int);
11253 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11254 sockflagsize = fdoff + 2;
11256 if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11257 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11266 * Clear the corresponding bit when the (possibly) socket stream is closed.
11267 * There still a small hole: we miss an implicit close which might occur
11268 * via freopen(). >> Todo
11270 /*{{{ int my_fclose(FILE *fp)*/
11271 int my_fclose(FILE *fp) {
11273 unsigned int fd = fileno(fp);
11274 unsigned int fdoff = fd / sizeof(unsigned int);
11276 if (sockflagsize && fdoff < sockflagsize)
11277 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11285 * A simple fwrite replacement which outputs itmsz*nitm chars without
11286 * introducing record boundaries every itmsz chars.
11287 * We are using fputs, which depends on a terminating null. We may
11288 * well be writing binary data, so we need to accommodate not only
11289 * data with nulls sprinkled in the middle but also data with no null
11292 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11294 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11296 register char *cp, *end, *cpd;
11298 register unsigned int fd = fileno(dest);
11299 register unsigned int fdoff = fd / sizeof(unsigned int);
11301 int bufsize = itmsz * nitm + 1;
11303 if (fdoff < sockflagsize &&
11304 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11305 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11309 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11310 memcpy( data, src, itmsz*nitm );
11311 data[itmsz*nitm] = '\0';
11313 end = data + itmsz * nitm;
11314 retval = (int) nitm; /* on success return # items written */
11317 while (cpd <= end) {
11318 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11319 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11321 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11325 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11328 } /* end of my_fwrite() */
11331 /*{{{ int my_flush(FILE *fp)*/
11333 Perl_my_flush(pTHX_ FILE *fp)
11336 if ((res = fflush(fp)) == 0 && fp) {
11337 #ifdef VMS_DO_SOCKETS
11339 if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11341 res = fsync(fileno(fp));
11344 * If the flush succeeded but set end-of-file, we need to clear
11345 * the error because our caller may check ferror(). BTW, this
11346 * probably means we just flushed an empty file.
11348 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11354 /* fgetname() is not returning the correct file specifications when
11355 * decc_filename_unix_report mode is active. So we have to have it
11356 * aways return filenames in VMS mode and convert it ourselves.
11359 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11361 Perl_my_fgetname(FILE *fp, char * buf) {
11365 retname = fgetname(fp, buf, 1);
11367 /* If we are in VMS mode, then we are done */
11368 if (!decc_filename_unix_report || (retname == NULL)) {
11372 /* Convert this to Unix format */
11373 vms_name = PerlMem_malloc(VMS_MAXRSS + 1);
11374 strcpy(vms_name, retname);
11375 retname = int_tounixspec(vms_name, buf, NULL);
11376 PerlMem_free(vms_name);
11383 * Here are replacements for the following Unix routines in the VMS environment:
11384 * getpwuid Get information for a particular UIC or UID
11385 * getpwnam Get information for a named user
11386 * getpwent Get information for each user in the rights database
11387 * setpwent Reset search to the start of the rights database
11388 * endpwent Finish searching for users in the rights database
11390 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11391 * (defined in pwd.h), which contains the following fields:-
11393 * char *pw_name; Username (in lower case)
11394 * char *pw_passwd; Hashed password
11395 * unsigned int pw_uid; UIC
11396 * unsigned int pw_gid; UIC group number
11397 * char *pw_unixdir; Default device/directory (VMS-style)
11398 * char *pw_gecos; Owner name
11399 * char *pw_dir; Default device/directory (Unix-style)
11400 * char *pw_shell; Default CLI name (eg. DCL)
11402 * If the specified user does not exist, getpwuid and getpwnam return NULL.
11404 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11405 * not the UIC member number (eg. what's returned by getuid()),
11406 * getpwuid() can accept either as input (if uid is specified, the caller's
11407 * UIC group is used), though it won't recognise gid=0.
11409 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11410 * information about other users in your group or in other groups, respectively.
11411 * If the required privilege is not available, then these routines fill only
11412 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11415 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11418 /* sizes of various UAF record fields */
11419 #define UAI$S_USERNAME 12
11420 #define UAI$S_IDENT 31
11421 #define UAI$S_OWNER 31
11422 #define UAI$S_DEFDEV 31
11423 #define UAI$S_DEFDIR 63
11424 #define UAI$S_DEFCLI 31
11425 #define UAI$S_PWD 8
11427 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
11428 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11429 (uic).uic$v_group != UIC$K_WILD_GROUP)
11431 static char __empty[]= "";
11432 static struct passwd __passwd_empty=
11433 {(char *) __empty, (char *) __empty, 0, 0,
11434 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11435 static int contxt= 0;
11436 static struct passwd __pwdcache;
11437 static char __pw_namecache[UAI$S_IDENT+1];
11440 * This routine does most of the work extracting the user information.
11442 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11445 unsigned char length;
11446 char pw_gecos[UAI$S_OWNER+1];
11448 static union uicdef uic;
11450 unsigned char length;
11451 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11454 unsigned char length;
11455 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11458 unsigned char length;
11459 char pw_shell[UAI$S_DEFCLI+1];
11461 static char pw_passwd[UAI$S_PWD+1];
11463 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11464 struct dsc$descriptor_s name_desc;
11465 unsigned long int sts;
11467 static struct itmlst_3 itmlst[]= {
11468 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
11469 {sizeof(uic), UAI$_UIC, &uic, &luic},
11470 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
11471 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
11472 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
11473 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
11474 {0, 0, NULL, NULL}};
11476 name_desc.dsc$w_length= strlen(name);
11477 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11478 name_desc.dsc$b_class= DSC$K_CLASS_S;
11479 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11481 /* Note that sys$getuai returns many fields as counted strings. */
11482 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11483 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11484 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11486 else { _ckvmssts(sts); }
11487 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
11489 if ((int) owner.length < lowner) lowner= (int) owner.length;
11490 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11491 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11492 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11493 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11494 owner.pw_gecos[lowner]= '\0';
11495 defdev.pw_dir[ldefdev+ldefdir]= '\0';
11496 defcli.pw_shell[ldefcli]= '\0';
11497 if (valid_uic(uic)) {
11498 pwd->pw_uid= uic.uic$l_uic;
11499 pwd->pw_gid= uic.uic$v_group;
11502 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11503 pwd->pw_passwd= pw_passwd;
11504 pwd->pw_gecos= owner.pw_gecos;
11505 pwd->pw_dir= defdev.pw_dir;
11506 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11507 pwd->pw_shell= defcli.pw_shell;
11508 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11510 ldir= strlen(pwd->pw_unixdir) - 1;
11511 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11514 strcpy(pwd->pw_unixdir, pwd->pw_dir);
11515 if (!decc_efs_case_preserve)
11516 __mystrtolower(pwd->pw_unixdir);
11521 * Get information for a named user.
11523 /*{{{struct passwd *getpwnam(char *name)*/
11524 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11526 struct dsc$descriptor_s name_desc;
11528 unsigned long int status, sts;
11530 __pwdcache = __passwd_empty;
11531 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11532 /* We still may be able to determine pw_uid and pw_gid */
11533 name_desc.dsc$w_length= strlen(name);
11534 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11535 name_desc.dsc$b_class= DSC$K_CLASS_S;
11536 name_desc.dsc$a_pointer= (char *) name;
11537 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11538 __pwdcache.pw_uid= uic.uic$l_uic;
11539 __pwdcache.pw_gid= uic.uic$v_group;
11542 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11543 set_vaxc_errno(sts);
11544 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11547 else { _ckvmssts(sts); }
11550 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11551 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11552 __pwdcache.pw_name= __pw_namecache;
11553 return &__pwdcache;
11554 } /* end of my_getpwnam() */
11558 * Get information for a particular UIC or UID.
11559 * Called by my_getpwent with uid=-1 to list all users.
11561 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11562 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11564 const $DESCRIPTOR(name_desc,__pw_namecache);
11565 unsigned short lname;
11567 unsigned long int status;
11569 if (uid == (unsigned int) -1) {
11571 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11572 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11573 set_vaxc_errno(status);
11574 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11578 else { _ckvmssts(status); }
11579 } while (!valid_uic (uic));
11582 uic.uic$l_uic= uid;
11583 if (!uic.uic$v_group)
11584 uic.uic$v_group= PerlProc_getgid();
11585 if (valid_uic(uic))
11586 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11587 else status = SS$_IVIDENT;
11588 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11589 status == RMS$_PRV) {
11590 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11593 else { _ckvmssts(status); }
11595 __pw_namecache[lname]= '\0';
11596 __mystrtolower(__pw_namecache);
11598 __pwdcache = __passwd_empty;
11599 __pwdcache.pw_name = __pw_namecache;
11601 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11602 The identifier's value is usually the UIC, but it doesn't have to be,
11603 so if we can, we let fillpasswd update this. */
11604 __pwdcache.pw_uid = uic.uic$l_uic;
11605 __pwdcache.pw_gid = uic.uic$v_group;
11607 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11608 return &__pwdcache;
11610 } /* end of my_getpwuid() */
11614 * Get information for next user.
11616 /*{{{struct passwd *my_getpwent()*/
11617 struct passwd *Perl_my_getpwent(pTHX)
11619 return (my_getpwuid((unsigned int) -1));
11624 * Finish searching rights database for users.
11626 /*{{{void my_endpwent()*/
11627 void Perl_my_endpwent(pTHX)
11630 _ckvmssts(sys$finish_rdb(&contxt));
11636 #ifdef HOMEGROWN_POSIX_SIGNALS
11637 /* Signal handling routines, pulled into the core from POSIX.xs.
11639 * We need these for threads, so they've been rolled into the core,
11640 * rather than left in POSIX.xs.
11642 * (DRS, Oct 23, 1997)
11645 /* sigset_t is atomic under VMS, so these routines are easy */
11646 /*{{{int my_sigemptyset(sigset_t *) */
11647 int my_sigemptyset(sigset_t *set) {
11648 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11649 *set = 0; return 0;
11654 /*{{{int my_sigfillset(sigset_t *)*/
11655 int my_sigfillset(sigset_t *set) {
11657 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11658 for (i = 0; i < NSIG; i++) *set |= (1 << i);
11664 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11665 int my_sigaddset(sigset_t *set, int sig) {
11666 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11667 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11668 *set |= (1 << (sig - 1));
11674 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11675 int my_sigdelset(sigset_t *set, int sig) {
11676 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11677 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11678 *set &= ~(1 << (sig - 1));
11684 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11685 int my_sigismember(sigset_t *set, int sig) {
11686 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11687 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11688 return *set & (1 << (sig - 1));
11693 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11694 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11697 /* If set and oset are both null, then things are badly wrong. Bail out. */
11698 if ((oset == NULL) && (set == NULL)) {
11699 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11703 /* If set's null, then we're just handling a fetch. */
11705 tempmask = sigblock(0);
11710 tempmask = sigsetmask(*set);
11713 tempmask = sigblock(*set);
11716 tempmask = sigblock(0);
11717 sigsetmask(*oset & ~tempmask);
11720 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11725 /* Did they pass us an oset? If so, stick our holding mask into it */
11732 #endif /* HOMEGROWN_POSIX_SIGNALS */
11735 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11736 * my_utime(), and flex_stat(), all of which operate on UTC unless
11737 * VMSISH_TIMES is true.
11739 /* method used to handle UTC conversions:
11740 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
11742 static int gmtime_emulation_type;
11743 /* number of secs to add to UTC POSIX-style time to get local time */
11744 static long int utc_offset_secs;
11746 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11747 * in vmsish.h. #undef them here so we can call the CRTL routines
11756 * DEC C previous to 6.0 corrupts the behavior of the /prefix
11757 * qualifier with the extern prefix pragma. This provisional
11758 * hack circumvents this prefix pragma problem in previous
11761 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11762 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11763 # pragma __extern_prefix save
11764 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
11765 # define gmtime decc$__utctz_gmtime
11766 # define localtime decc$__utctz_localtime
11767 # define time decc$__utc_time
11768 # pragma __extern_prefix restore
11770 struct tm *gmtime(), *localtime();
11776 static time_t toutc_dst(time_t loc) {
11779 if ((rsltmp = localtime(&loc)) == NULL) return -1;
11780 loc -= utc_offset_secs;
11781 if (rsltmp->tm_isdst) loc -= 3600;
11784 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11785 ((gmtime_emulation_type || my_time(NULL)), \
11786 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11787 ((secs) - utc_offset_secs))))
11789 static time_t toloc_dst(time_t utc) {
11792 utc += utc_offset_secs;
11793 if ((rsltmp = localtime(&utc)) == NULL) return -1;
11794 if (rsltmp->tm_isdst) utc += 3600;
11797 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11798 ((gmtime_emulation_type || my_time(NULL)), \
11799 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11800 ((secs) + utc_offset_secs))))
11802 #ifndef RTL_USES_UTC
11805 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
11806 DST starts on 1st sun of april at 02:00 std time
11807 ends on last sun of october at 02:00 dst time
11808 see the UCX management command reference, SET CONFIG TIMEZONE
11809 for formatting info.
11811 No, it's not as general as it should be, but then again, NOTHING
11812 will handle UK times in a sensible way.
11817 parse the DST start/end info:
11818 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11822 tz_parse_startend(char *s, struct tm *w, int *past)
11824 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11825 int ly, dozjd, d, m, n, hour, min, sec, j, k;
11830 if (!past) return 0;
11833 if (w->tm_year % 4 == 0) ly = 1;
11834 if (w->tm_year % 100 == 0) ly = 0;
11835 if (w->tm_year+1900 % 400 == 0) ly = 1;
11838 dozjd = isdigit(*s);
11839 if (*s == 'J' || *s == 'j' || dozjd) {
11840 if (!dozjd && !isdigit(*++s)) return 0;
11843 d = d*10 + *s++ - '0';
11845 d = d*10 + *s++ - '0';
11848 if (d == 0) return 0;
11849 if (d > 366) return 0;
11851 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
11854 } else if (*s == 'M' || *s == 'm') {
11855 if (!isdigit(*++s)) return 0;
11857 if (isdigit(*s)) m = 10*m + *s++ - '0';
11858 if (*s != '.') return 0;
11859 if (!isdigit(*++s)) return 0;
11861 if (n < 1 || n > 5) return 0;
11862 if (*s != '.') return 0;
11863 if (!isdigit(*++s)) return 0;
11865 if (d > 6) return 0;
11869 if (!isdigit(*++s)) return 0;
11871 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11873 if (!isdigit(*++s)) return 0;
11875 if (isdigit(*s)) min = 10*min + *s++ - '0';
11877 if (!isdigit(*++s)) return 0;
11879 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11889 if (w->tm_yday < d) goto before;
11890 if (w->tm_yday > d) goto after;
11892 if (w->tm_mon+1 < m) goto before;
11893 if (w->tm_mon+1 > m) goto after;
11895 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
11896 k = d - j; /* mday of first d */
11897 if (k <= 0) k += 7;
11898 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
11899 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11900 if (w->tm_mday < k) goto before;
11901 if (w->tm_mday > k) goto after;
11904 if (w->tm_hour < hour) goto before;
11905 if (w->tm_hour > hour) goto after;
11906 if (w->tm_min < min) goto before;
11907 if (w->tm_min > min) goto after;
11908 if (w->tm_sec < sec) goto before;
11922 /* parse the offset: (+|-)hh[:mm[:ss]] */
11925 tz_parse_offset(char *s, int *offset)
11927 int hour = 0, min = 0, sec = 0;
11930 if (!offset) return 0;
11932 if (*s == '-') {neg++; s++;}
11933 if (*s == '+') s++;
11934 if (!isdigit(*s)) return 0;
11936 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11937 if (hour > 24) return 0;
11939 if (!isdigit(*++s)) return 0;
11941 if (isdigit(*s)) min = min*10 + (*s++ - '0');
11942 if (min > 59) return 0;
11944 if (!isdigit(*++s)) return 0;
11946 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11947 if (sec > 59) return 0;
11951 *offset = (hour*60+min)*60 + sec;
11952 if (neg) *offset = -*offset;
11957 input time is w, whatever type of time the CRTL localtime() uses.
11958 sets dst, the zone, and the gmtoff (seconds)
11960 caches the value of TZ and UCX$TZ env variables; note that
11961 my_setenv looks for these and sets a flag if they're changed
11964 We have to watch out for the "australian" case (dst starts in
11965 october, ends in april)...flagged by "reverse" and checked by
11966 scanning through the months of the previous year.
11971 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11976 char *dstzone, *tz, *s_start, *s_end;
11977 int std_off, dst_off, isdst;
11978 int y, dststart, dstend;
11979 static char envtz[1025]; /* longer than any logical, symbol, ... */
11980 static char ucxtz[1025];
11981 static char reversed = 0;
11987 reversed = -1; /* flag need to check */
11988 envtz[0] = ucxtz[0] = '\0';
11989 tz = my_getenv("TZ",0);
11990 if (tz) strcpy(envtz, tz);
11991 tz = my_getenv("UCX$TZ",0);
11992 if (tz) strcpy(ucxtz, tz);
11993 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
11996 if (!*tz) tz = ucxtz;
11999 while (isalpha(*s)) s++;
12000 s = tz_parse_offset(s, &std_off);
12002 if (!*s) { /* no DST, hurray we're done! */
12008 while (isalpha(*s)) s++;
12009 s2 = tz_parse_offset(s, &dst_off);
12013 dst_off = std_off - 3600;
12016 if (!*s) { /* default dst start/end?? */
12017 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
12018 s = strchr(ucxtz,',');
12020 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
12022 if (*s != ',') return 0;
12025 when = _toutc(when); /* convert to utc */
12026 when = when - std_off; /* convert to pseudolocal time*/
12028 w2 = localtime(&when);
12031 s = tz_parse_startend(s_start,w2,&dststart);
12033 if (*s != ',') return 0;
12036 when = _toutc(when); /* convert to utc */
12037 when = when - dst_off; /* convert to pseudolocal time*/
12038 w2 = localtime(&when);
12039 if (w2->tm_year != y) { /* spans a year, just check one time */
12040 when += dst_off - std_off;
12041 w2 = localtime(&when);
12044 s = tz_parse_startend(s_end,w2,&dstend);
12047 if (reversed == -1) { /* need to check if start later than end */
12051 if (when < 2*365*86400) {
12052 when += 2*365*86400;
12056 w2 =localtime(&when);
12057 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
12059 for (j = 0; j < 12; j++) {
12060 w2 =localtime(&when);
12061 tz_parse_startend(s_start,w2,&ds);
12062 tz_parse_startend(s_end,w2,&de);
12063 if (ds != de) break;
12067 if (de && !ds) reversed = 1;
12070 isdst = dststart && !dstend;
12071 if (reversed) isdst = dststart || !dstend;
12074 if (dst) *dst = isdst;
12075 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
12076 if (isdst) tz = dstzone;
12078 while(isalpha(*tz)) *zone++ = *tz++;
12084 #endif /* !RTL_USES_UTC */
12086 /* my_time(), my_localtime(), my_gmtime()
12087 * By default traffic in UTC time values, using CRTL gmtime() or
12088 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
12089 * Note: We need to use these functions even when the CRTL has working
12090 * UTC support, since they also handle C<use vmsish qw(times);>
12092 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
12093 * Modified by Charles Bailey <bailey@newman.upenn.edu>
12096 /*{{{time_t my_time(time_t *timep)*/
12097 time_t Perl_my_time(pTHX_ time_t *timep)
12102 if (gmtime_emulation_type == 0) {
12104 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
12105 /* results of calls to gmtime() and localtime() */
12106 /* for same &base */
12108 gmtime_emulation_type++;
12109 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
12110 char off[LNM$C_NAMLENGTH+1];;
12112 gmtime_emulation_type++;
12113 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
12114 gmtime_emulation_type++;
12115 utc_offset_secs = 0;
12116 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
12118 else { utc_offset_secs = atol(off); }
12120 else { /* We've got a working gmtime() */
12121 struct tm gmt, local;
12124 tm_p = localtime(&base);
12126 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
12127 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
12128 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
12129 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
12134 # ifdef VMSISH_TIME
12135 # ifdef RTL_USES_UTC
12136 if (VMSISH_TIME) when = _toloc(when);
12138 if (!VMSISH_TIME) when = _toutc(when);
12141 if (timep != NULL) *timep = when;
12144 } /* end of my_time() */
12148 /*{{{struct tm *my_gmtime(const time_t *timep)*/
12150 Perl_my_gmtime(pTHX_ const time_t *timep)
12156 if (timep == NULL) {
12157 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12160 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
12163 # ifdef VMSISH_TIME
12164 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
12166 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
12167 return gmtime(&when);
12169 /* CRTL localtime() wants local time as input, so does no tz correction */
12170 rsltmp = localtime(&when);
12171 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
12174 } /* end of my_gmtime() */
12178 /*{{{struct tm *my_localtime(const time_t *timep)*/
12180 Perl_my_localtime(pTHX_ const time_t *timep)
12182 time_t when, whenutc;
12186 if (timep == NULL) {
12187 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12190 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
12191 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
12194 # ifdef RTL_USES_UTC
12195 # ifdef VMSISH_TIME
12196 if (VMSISH_TIME) when = _toutc(when);
12198 /* CRTL localtime() wants UTC as input, does tz correction itself */
12199 return localtime(&when);
12201 # else /* !RTL_USES_UTC */
12203 # ifdef VMSISH_TIME
12204 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
12205 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
12208 #ifndef RTL_USES_UTC
12209 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
12210 when = whenutc - offset; /* pseudolocal time*/
12213 /* CRTL localtime() wants local time as input, so does no tz correction */
12214 rsltmp = localtime(&when);
12215 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12219 } /* end of my_localtime() */
12222 /* Reset definitions for later calls */
12223 #define gmtime(t) my_gmtime(t)
12224 #define localtime(t) my_localtime(t)
12225 #define time(t) my_time(t)
12228 /* my_utime - update modification/access time of a file
12230 * VMS 7.3 and later implementation
12231 * Only the UTC translation is home-grown. The rest is handled by the
12232 * CRTL utime(), which will take into account the relevant feature
12233 * logicals and ODS-5 volume characteristics for true access times.
12235 * pre VMS 7.3 implementation:
12236 * The calling sequence is identical to POSIX utime(), but under
12237 * VMS with ODS-2, only the modification time is changed; ODS-2 does
12238 * not maintain access times. Restrictions differ from the POSIX
12239 * definition in that the time can be changed as long as the
12240 * caller has permission to execute the necessary IO$_MODIFY $QIO;
12241 * no separate checks are made to insure that the caller is the
12242 * owner of the file or has special privs enabled.
12243 * Code here is based on Joe Meadows' FILE utility.
12247 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12248 * to VMS epoch (01-JAN-1858 00:00:00.00)
12249 * in 100 ns intervals.
12251 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12253 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12254 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12256 #if __CRTL_VER >= 70300000
12257 struct utimbuf utc_utimes, *utc_utimesp;
12259 if (utimes != NULL) {
12260 utc_utimes.actime = utimes->actime;
12261 utc_utimes.modtime = utimes->modtime;
12262 # ifdef VMSISH_TIME
12263 /* If input was local; convert to UTC for sys svc */
12265 utc_utimes.actime = _toutc(utimes->actime);
12266 utc_utimes.modtime = _toutc(utimes->modtime);
12269 utc_utimesp = &utc_utimes;
12272 utc_utimesp = NULL;
12275 return utime(file, utc_utimesp);
12277 #else /* __CRTL_VER < 70300000 */
12281 long int bintime[2], len = 2, lowbit, unixtime,
12282 secscale = 10000000; /* seconds --> 100 ns intervals */
12283 unsigned long int chan, iosb[2], retsts;
12284 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12285 struct FAB myfab = cc$rms_fab;
12286 struct NAM mynam = cc$rms_nam;
12287 #if defined (__DECC) && defined (__VAX)
12288 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12289 * at least through VMS V6.1, which causes a type-conversion warning.
12291 # pragma message save
12292 # pragma message disable cvtdiftypes
12294 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12295 struct fibdef myfib;
12296 #if defined (__DECC) && defined (__VAX)
12297 /* This should be right after the declaration of myatr, but due
12298 * to a bug in VAX DEC C, this takes effect a statement early.
12300 # pragma message restore
12302 /* cast ok for read only parameter */
12303 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12304 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12305 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12307 if (file == NULL || *file == '\0') {
12308 SETERRNO(ENOENT, LIB$_INVARG);
12312 /* Convert to VMS format ensuring that it will fit in 255 characters */
12313 if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12314 SETERRNO(ENOENT, LIB$_INVARG);
12317 if (utimes != NULL) {
12318 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
12319 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12320 * Since time_t is unsigned long int, and lib$emul takes a signed long int
12321 * as input, we force the sign bit to be clear by shifting unixtime right
12322 * one bit, then multiplying by an extra factor of 2 in lib$emul().
12324 lowbit = (utimes->modtime & 1) ? secscale : 0;
12325 unixtime = (long int) utimes->modtime;
12326 # ifdef VMSISH_TIME
12327 /* If input was UTC; convert to local for sys svc */
12328 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12330 unixtime >>= 1; secscale <<= 1;
12331 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12332 if (!(retsts & 1)) {
12333 SETERRNO(EVMSERR, retsts);
12336 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12337 if (!(retsts & 1)) {
12338 SETERRNO(EVMSERR, retsts);
12343 /* Just get the current time in VMS format directly */
12344 retsts = sys$gettim(bintime);
12345 if (!(retsts & 1)) {
12346 SETERRNO(EVMSERR, retsts);
12351 myfab.fab$l_fna = vmsspec;
12352 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12353 myfab.fab$l_nam = &mynam;
12354 mynam.nam$l_esa = esa;
12355 mynam.nam$b_ess = (unsigned char) sizeof esa;
12356 mynam.nam$l_rsa = rsa;
12357 mynam.nam$b_rss = (unsigned char) sizeof rsa;
12358 if (decc_efs_case_preserve)
12359 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12361 /* Look for the file to be affected, letting RMS parse the file
12362 * specification for us as well. I have set errno using only
12363 * values documented in the utime() man page for VMS POSIX.
12365 retsts = sys$parse(&myfab,0,0);
12366 if (!(retsts & 1)) {
12367 set_vaxc_errno(retsts);
12368 if (retsts == RMS$_PRV) set_errno(EACCES);
12369 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12370 else set_errno(EVMSERR);
12373 retsts = sys$search(&myfab,0,0);
12374 if (!(retsts & 1)) {
12375 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12376 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12377 set_vaxc_errno(retsts);
12378 if (retsts == RMS$_PRV) set_errno(EACCES);
12379 else if (retsts == RMS$_FNF) set_errno(ENOENT);
12380 else set_errno(EVMSERR);
12384 devdsc.dsc$w_length = mynam.nam$b_dev;
12385 /* cast ok for read only parameter */
12386 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12388 retsts = sys$assign(&devdsc,&chan,0,0);
12389 if (!(retsts & 1)) {
12390 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12391 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12392 set_vaxc_errno(retsts);
12393 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
12394 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
12395 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
12396 else set_errno(EVMSERR);
12400 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12401 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12403 memset((void *) &myfib, 0, sizeof myfib);
12404 #if defined(__DECC) || defined(__DECCXX)
12405 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12406 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12407 /* This prevents the revision time of the file being reset to the current
12408 * time as a result of our IO$_MODIFY $QIO. */
12409 myfib.fib$l_acctl = FIB$M_NORECORD;
12411 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12412 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12413 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12415 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12416 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12417 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12418 _ckvmssts(sys$dassgn(chan));
12419 if (retsts & 1) retsts = iosb[0];
12420 if (!(retsts & 1)) {
12421 set_vaxc_errno(retsts);
12422 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12423 else set_errno(EVMSERR);
12429 #endif /* #if __CRTL_VER >= 70300000 */
12431 } /* end of my_utime() */
12435 * flex_stat, flex_lstat, flex_fstat
12436 * basic stat, but gets it right when asked to stat
12437 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12440 #ifndef _USE_STD_STAT
12441 /* encode_dev packs a VMS device name string into an integer to allow
12442 * simple comparisons. This can be used, for example, to check whether two
12443 * files are located on the same device, by comparing their encoded device
12444 * names. Even a string comparison would not do, because stat() reuses the
12445 * device name buffer for each call; so without encode_dev, it would be
12446 * necessary to save the buffer and use strcmp (this would mean a number of
12447 * changes to the standard Perl code, to say nothing of what a Perl script
12448 * would have to do.
12450 * The device lock id, if it exists, should be unique (unless perhaps compared
12451 * with lock ids transferred from other nodes). We have a lock id if the disk is
12452 * mounted cluster-wide, which is when we tend to get long (host-qualified)
12453 * device names. Thus we use the lock id in preference, and only if that isn't
12454 * available, do we try to pack the device name into an integer (flagged by
12455 * the sign bit (LOCKID_MASK) being set).
12457 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12458 * name and its encoded form, but it seems very unlikely that we will find
12459 * two files on different disks that share the same encoded device names,
12460 * and even more remote that they will share the same file id (if the test
12461 * is to check for the same file).
12463 * A better method might be to use sys$device_scan on the first call, and to
12464 * search for the device, returning an index into the cached array.
12465 * The number returned would be more intelligible.
12466 * This is probably not worth it, and anyway would take quite a bit longer
12467 * on the first call.
12469 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
12470 static mydev_t encode_dev (pTHX_ const char *dev)
12473 unsigned long int f;
12478 if (!dev || !dev[0]) return 0;
12482 struct dsc$descriptor_s dev_desc;
12483 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12485 /* For cluster-mounted disks, the disk lock identifier is unique, so we
12486 can try that first. */
12487 dev_desc.dsc$w_length = strlen (dev);
12488 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
12489 dev_desc.dsc$b_class = DSC$K_CLASS_S;
12490 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
12491 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12492 if (!$VMS_STATUS_SUCCESS(status)) {
12494 case SS$_NOSUCHDEV:
12495 SETERRNO(ENODEV, status);
12501 if (lockid) return (lockid & ~LOCKID_MASK);
12505 /* Otherwise we try to encode the device name */
12509 for (q = dev + strlen(dev); q--; q >= dev) {
12514 else if (isalpha (toupper (*q)))
12515 c= toupper (*q) - 'A' + (char)10;
12517 continue; /* Skip '$'s */
12519 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
12521 enc += f * (unsigned long int) c;
12523 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
12525 } /* end of encode_dev() */
12526 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12527 device_no = encode_dev(aTHX_ devname)
12529 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12530 device_no = new_dev_no
12534 is_null_device(name)
12537 if (decc_bug_devnull != 0) {
12538 if (strncmp("/dev/null", name, 9) == 0)
12541 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12542 The underscore prefix, controller letter, and unit number are
12543 independently optional; for our purposes, the colon punctuation
12544 is not. The colon can be trailed by optional directory and/or
12545 filename, but two consecutive colons indicates a nodename rather
12546 than a device. [pr] */
12547 if (*name == '_') ++name;
12548 if (tolower(*name++) != 'n') return 0;
12549 if (tolower(*name++) != 'l') return 0;
12550 if (tolower(*name) == 'a') ++name;
12551 if (*name == '0') ++name;
12552 return (*name++ == ':') && (*name != ':');
12556 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
12558 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
12561 Perl_cando_by_name_int
12562 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12564 char usrname[L_cuserid];
12565 struct dsc$descriptor_s usrdsc =
12566 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12567 char *vmsname = NULL, *fileified = NULL;
12568 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12569 unsigned short int retlen, trnlnm_iter_count;
12570 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12571 union prvdef curprv;
12572 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12573 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12574 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12575 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12576 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12578 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12580 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12582 static int profile_context = -1;
12584 if (!fname || !*fname) return FALSE;
12586 /* Make sure we expand logical names, since sys$check_access doesn't */
12587 fileified = PerlMem_malloc(VMS_MAXRSS);
12588 if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12589 if (!strpbrk(fname,"/]>:")) {
12590 strcpy(fileified,fname);
12591 trnlnm_iter_count = 0;
12592 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12593 trnlnm_iter_count++;
12594 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12599 vmsname = PerlMem_malloc(VMS_MAXRSS);
12600 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12601 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12602 /* Don't know if already in VMS format, so make sure */
12603 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12604 PerlMem_free(fileified);
12605 PerlMem_free(vmsname);
12610 strcpy(vmsname,fname);
12613 /* sys$check_access needs a file spec, not a directory spec.
12614 * flex_stat now will handle a null thread context during startup.
12617 retlen = namdsc.dsc$w_length = strlen(vmsname);
12618 if (vmsname[retlen-1] == ']'
12619 || vmsname[retlen-1] == '>'
12620 || vmsname[retlen-1] == ':'
12621 || (!flex_stat_int(vmsname, &st, 1) &&
12622 S_ISDIR(st.st_mode))) {
12624 if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12625 PerlMem_free(fileified);
12626 PerlMem_free(vmsname);
12635 retlen = namdsc.dsc$w_length = strlen(fname);
12636 namdsc.dsc$a_pointer = (char *)fname;
12639 case S_IXUSR: case S_IXGRP: case S_IXOTH:
12640 access = ARM$M_EXECUTE;
12641 flags = CHP$M_READ;
12643 case S_IRUSR: case S_IRGRP: case S_IROTH:
12644 access = ARM$M_READ;
12645 flags = CHP$M_READ | CHP$M_USEREADALL;
12647 case S_IWUSR: case S_IWGRP: case S_IWOTH:
12648 access = ARM$M_WRITE;
12649 flags = CHP$M_READ | CHP$M_WRITE;
12651 case S_IDUSR: case S_IDGRP: case S_IDOTH:
12652 access = ARM$M_DELETE;
12653 flags = CHP$M_READ | CHP$M_WRITE;
12656 if (fileified != NULL)
12657 PerlMem_free(fileified);
12658 if (vmsname != NULL)
12659 PerlMem_free(vmsname);
12663 /* Before we call $check_access, create a user profile with the current
12664 * process privs since otherwise it just uses the default privs from the
12665 * UAF and might give false positives or negatives. This only works on
12666 * VMS versions v6.0 and later since that's when sys$create_user_profile
12667 * became available.
12670 /* get current process privs and username */
12671 _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12672 _ckvmssts_noperl(iosb[0]);
12674 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12676 /* find out the space required for the profile */
12677 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12678 &usrprodsc.dsc$w_length,&profile_context));
12680 /* allocate space for the profile and get it filled in */
12681 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12682 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12683 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12684 &usrprodsc.dsc$w_length,&profile_context));
12686 /* use the profile to check access to the file; free profile & analyze results */
12687 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12688 PerlMem_free(usrprodsc.dsc$a_pointer);
12689 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12693 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12697 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
12698 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12699 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12700 set_vaxc_errno(retsts);
12701 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12702 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12703 else set_errno(ENOENT);
12704 if (fileified != NULL)
12705 PerlMem_free(fileified);
12706 if (vmsname != NULL)
12707 PerlMem_free(vmsname);
12710 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12711 if (fileified != NULL)
12712 PerlMem_free(fileified);
12713 if (vmsname != NULL)
12714 PerlMem_free(vmsname);
12717 _ckvmssts_noperl(retsts);
12719 if (fileified != NULL)
12720 PerlMem_free(fileified);
12721 if (vmsname != NULL)
12722 PerlMem_free(vmsname);
12723 return FALSE; /* Should never get here */
12727 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
12728 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12729 * subset of the applicable information.
12732 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12734 return cando_by_name_int
12735 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12736 } /* end of cando() */
12740 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12742 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12744 return cando_by_name_int(bit, effective, fname, 0);
12746 } /* end of cando_by_name() */
12750 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12752 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12754 if (!fstat(fd, &statbufp->crtl_stat)) {
12756 char *vms_filename;
12757 vms_filename = PerlMem_malloc(VMS_MAXRSS);
12758 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12760 /* Save name for cando by name in VMS format */
12761 cptr = getname(fd, vms_filename, 1);
12763 /* This should not happen, but just in case */
12764 if (cptr == NULL) {
12765 statbufp->st_devnam[0] = 0;
12768 /* Make sure that the saved name fits in 255 characters */
12769 cptr = int_rmsexpand_vms
12771 statbufp->st_devnam,
12774 statbufp->st_devnam[0] = 0;
12776 PerlMem_free(vms_filename);
12778 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12780 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12782 # ifdef RTL_USES_UTC
12783 # ifdef VMSISH_TIME
12785 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12786 statbufp->st_atime = _toloc(statbufp->st_atime);
12787 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12791 # ifdef VMSISH_TIME
12792 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12796 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12797 statbufp->st_atime = _toutc(statbufp->st_atime);
12798 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12805 } /* end of flex_fstat() */
12809 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12813 const char *save_spec;
12824 if (decc_bug_devnull != 0) {
12825 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12826 memset(statbufp,0,sizeof *statbufp);
12827 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12828 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12829 statbufp->st_uid = 0x00010001;
12830 statbufp->st_gid = 0x0001;
12831 time((time_t *)&statbufp->st_mtime);
12832 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12837 /* Try for a directory name first. If fspec contains a filename without
12838 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12839 * and sea:[wine.dark]water. exist, we prefer the directory here.
12840 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12841 * not sea:[wine.dark]., if the latter exists. If the intended target is
12842 * the file with null type, specify this by calling flex_stat() with
12843 * a '.' at the end of fspec.
12845 * If we are in Posix filespec mode, accept the filename as is.
12849 fileified = PerlMem_malloc(VMS_MAXRSS);
12850 if (fileified == NULL)
12851 _ckvmssts_noperl(SS$_INSFMEM);
12853 temp_fspec = PerlMem_malloc(VMS_MAXRSS);
12854 if (temp_fspec == NULL)
12855 _ckvmssts_noperl(SS$_INSFMEM);
12857 strcpy(temp_fspec, fspec);
12861 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12862 if (decc_posix_compliant_pathnames == 0) {
12865 /* We may be able to optimize this, but in order for fileify_dirspec to
12866 * always return a usuable answer, we have to call vmspath first to
12867 * make sure that it is in VMS directory format, as stat/lstat on 8.3
12868 * can not handle directories in unix format that it does not have read
12869 * access to. Vmspath handles the case where a bare name which could be
12870 * a logical name gets passed.
12872 ret_spec = int_tovmspath(fspec, temp_fspec, NULL);
12873 if (ret_spec != NULL) {
12874 ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
12875 if (ret_spec != NULL) {
12876 if (lstat_flag == 0)
12877 retval = stat(fileified, &statbufp->crtl_stat);
12879 retval = lstat(fileified, &statbufp->crtl_stat);
12880 save_spec = fileified;
12884 if (retval && vms_bug_stat_filename) {
12886 /* We should try again as a vmsified file specification */
12887 /* However Perl traditionally has not done this, which */
12888 /* causes problems with existing tests */
12890 ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12891 if (ret_spec != NULL) {
12892 if (lstat_flag == 0)
12893 retval = stat(temp_fspec, &statbufp->crtl_stat);
12895 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12896 save_spec = temp_fspec;
12901 /* Last chance - allow multiple dots with out EFS CHARSET */
12902 /* The CRTL stat() falls down hard on multi-dot filenames in unix
12903 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12904 * enable it if it isn't already.
12906 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12907 if (!decc_efs_charset && (decc_efs_charset_index > 0))
12908 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12910 if (lstat_flag == 0)
12911 retval = stat(fspec, &statbufp->crtl_stat);
12913 retval = lstat(fspec, &statbufp->crtl_stat);
12915 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12916 if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12917 decc$feature_set_value(decc_efs_charset_index, 1, 0);
12923 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12925 if (lstat_flag == 0)
12926 retval = stat(temp_fspec, &statbufp->crtl_stat);
12928 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12929 save_spec = temp_fspec;
12933 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12934 /* As you were... */
12935 if (!decc_efs_charset)
12936 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12941 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12943 /* If this is an lstat, do not follow the link */
12945 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12947 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12948 /* If we used the efs_hack above, we must also use it here for */
12949 /* perl_cando to work */
12950 if (efs_hack && (decc_efs_charset_index > 0)) {
12951 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12954 cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12955 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12956 if (efs_hack && (decc_efs_charset_index > 0)) {
12957 decc$feature_set_value(decc_efs_charset, 1, 0);
12961 /* Fix me: If this is NULL then stat found a file, and we could */
12962 /* not convert the specification to VMS - Should never happen */
12964 statbufp->st_devnam[0] = 0;
12966 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12968 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12969 # ifdef RTL_USES_UTC
12970 # ifdef VMSISH_TIME
12972 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12973 statbufp->st_atime = _toloc(statbufp->st_atime);
12974 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12978 # ifdef VMSISH_TIME
12979 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12983 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12984 statbufp->st_atime = _toutc(statbufp->st_atime);
12985 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12989 /* If we were successful, leave errno where we found it */
12990 if (retval == 0) RESTORE_ERRNO;
12993 } /* end of flex_stat_int() */
12996 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12998 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
13000 return flex_stat_int(fspec, statbufp, 0);
13004 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
13006 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
13008 return flex_stat_int(fspec, statbufp, 1);
13013 /*{{{char *my_getlogin()*/
13014 /* VMS cuserid == Unix getlogin, except calling sequence */
13018 static char user[L_cuserid];
13019 return cuserid(user);
13024 /* rmscopy - copy a file using VMS RMS routines
13026 * Copies contents and attributes of spec_in to spec_out, except owner
13027 * and protection information. Name and type of spec_in are used as
13028 * defaults for spec_out. The third parameter specifies whether rmscopy()
13029 * should try to propagate timestamps from the input file to the output file.
13030 * If it is less than 0, no timestamps are preserved. If it is 0, then
13031 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
13032 * propagated to the output file at creation iff the output file specification
13033 * did not contain an explicit name or type, and the revision date is always
13034 * updated at the end of the copy operation. If it is greater than 0, then
13035 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
13036 * other than the revision date should be propagated, and bit 1 indicates
13037 * that the revision date should be propagated.
13039 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
13041 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
13042 * Incorporates, with permission, some code from EZCOPY by Tim Adye
13043 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
13044 * as part of the Perl standard distribution under the terms of the
13045 * GNU General Public License or the Perl Artistic License. Copies
13046 * of each may be found in the Perl standard distribution.
13048 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
13050 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
13052 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
13053 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
13054 unsigned long int i, sts, sts2;
13056 struct FAB fab_in, fab_out;
13057 struct RAB rab_in, rab_out;
13058 rms_setup_nam(nam);
13059 rms_setup_nam(nam_out);
13060 struct XABDAT xabdat;
13061 struct XABFHC xabfhc;
13062 struct XABRDT xabrdt;
13063 struct XABSUM xabsum;
13065 vmsin = PerlMem_malloc(VMS_MAXRSS);
13066 if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13067 vmsout = PerlMem_malloc(VMS_MAXRSS);
13068 if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13069 if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
13070 !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
13071 PerlMem_free(vmsin);
13072 PerlMem_free(vmsout);
13073 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13077 esa = PerlMem_malloc(VMS_MAXRSS);
13078 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13080 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13081 esal = PerlMem_malloc(VMS_MAXRSS);
13082 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13084 fab_in = cc$rms_fab;
13085 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
13086 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
13087 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
13088 fab_in.fab$l_fop = FAB$M_SQO;
13089 rms_bind_fab_nam(fab_in, nam);
13090 fab_in.fab$l_xab = (void *) &xabdat;
13092 rsa = PerlMem_malloc(VMS_MAXRSS);
13093 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13095 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13096 rsal = PerlMem_malloc(VMS_MAXRSS);
13097 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13099 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
13100 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
13101 rms_nam_esl(nam) = 0;
13102 rms_nam_rsl(nam) = 0;
13103 rms_nam_esll(nam) = 0;
13104 rms_nam_rsll(nam) = 0;
13105 #ifdef NAM$M_NO_SHORT_UPCASE
13106 if (decc_efs_case_preserve)
13107 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
13110 xabdat = cc$rms_xabdat; /* To get creation date */
13111 xabdat.xab$l_nxt = (void *) &xabfhc;
13113 xabfhc = cc$rms_xabfhc; /* To get record length */
13114 xabfhc.xab$l_nxt = (void *) &xabsum;
13116 xabsum = cc$rms_xabsum; /* To get key and area information */
13118 if (!((sts = sys$open(&fab_in)) & 1)) {
13119 PerlMem_free(vmsin);
13120 PerlMem_free(vmsout);
13123 PerlMem_free(esal);
13126 PerlMem_free(rsal);
13127 set_vaxc_errno(sts);
13129 case RMS$_FNF: case RMS$_DNF:
13130 set_errno(ENOENT); break;
13132 set_errno(ENOTDIR); break;
13134 set_errno(ENODEV); break;
13136 set_errno(EINVAL); break;
13138 set_errno(EACCES); break;
13140 set_errno(EVMSERR);
13147 fab_out.fab$w_ifi = 0;
13148 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
13149 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
13150 fab_out.fab$l_fop = FAB$M_SQO;
13151 rms_bind_fab_nam(fab_out, nam_out);
13152 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
13153 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
13154 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
13155 esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13156 if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13157 rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13158 if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13161 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13162 esal_out = PerlMem_malloc(VMS_MAXRSS);
13163 if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13164 rsal_out = PerlMem_malloc(VMS_MAXRSS);
13165 if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13167 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
13168 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
13170 if (preserve_dates == 0) { /* Act like DCL COPY */
13171 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
13172 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
13173 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
13174 PerlMem_free(vmsin);
13175 PerlMem_free(vmsout);
13178 PerlMem_free(esal);
13181 PerlMem_free(rsal);
13182 PerlMem_free(esa_out);
13183 if (esal_out != NULL)
13184 PerlMem_free(esal_out);
13185 PerlMem_free(rsa_out);
13186 if (rsal_out != NULL)
13187 PerlMem_free(rsal_out);
13188 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
13189 set_vaxc_errno(sts);
13192 fab_out.fab$l_xab = (void *) &xabdat;
13193 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
13194 preserve_dates = 1;
13196 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
13197 preserve_dates =0; /* bitmask from this point forward */
13199 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
13200 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
13201 PerlMem_free(vmsin);
13202 PerlMem_free(vmsout);
13205 PerlMem_free(esal);
13208 PerlMem_free(rsal);
13209 PerlMem_free(esa_out);
13210 if (esal_out != NULL)
13211 PerlMem_free(esal_out);
13212 PerlMem_free(rsa_out);
13213 if (rsal_out != NULL)
13214 PerlMem_free(rsal_out);
13215 set_vaxc_errno(sts);
13218 set_errno(ENOENT); break;
13220 set_errno(ENOTDIR); break;
13222 set_errno(ENODEV); break;
13224 set_errno(EINVAL); break;
13226 set_errno(EACCES); break;
13228 set_errno(EVMSERR);
13232 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
13233 if (preserve_dates & 2) {
13234 /* sys$close() will process xabrdt, not xabdat */
13235 xabrdt = cc$rms_xabrdt;
13237 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
13239 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
13240 * is unsigned long[2], while DECC & VAXC use a struct */
13241 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
13243 fab_out.fab$l_xab = (void *) &xabrdt;
13246 ubf = PerlMem_malloc(32256);
13247 if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13248 rab_in = cc$rms_rab;
13249 rab_in.rab$l_fab = &fab_in;
13250 rab_in.rab$l_rop = RAB$M_BIO;
13251 rab_in.rab$l_ubf = ubf;
13252 rab_in.rab$w_usz = 32256;
13253 if (!((sts = sys$connect(&rab_in)) & 1)) {
13254 sys$close(&fab_in); sys$close(&fab_out);
13255 PerlMem_free(vmsin);
13256 PerlMem_free(vmsout);
13260 PerlMem_free(esal);
13263 PerlMem_free(rsal);
13264 PerlMem_free(esa_out);
13265 if (esal_out != NULL)
13266 PerlMem_free(esal_out);
13267 PerlMem_free(rsa_out);
13268 if (rsal_out != NULL)
13269 PerlMem_free(rsal_out);
13270 set_errno(EVMSERR); set_vaxc_errno(sts);
13274 rab_out = cc$rms_rab;
13275 rab_out.rab$l_fab = &fab_out;
13276 rab_out.rab$l_rbf = ubf;
13277 if (!((sts = sys$connect(&rab_out)) & 1)) {
13278 sys$close(&fab_in); sys$close(&fab_out);
13279 PerlMem_free(vmsin);
13280 PerlMem_free(vmsout);
13284 PerlMem_free(esal);
13287 PerlMem_free(rsal);
13288 PerlMem_free(esa_out);
13289 if (esal_out != NULL)
13290 PerlMem_free(esal_out);
13291 PerlMem_free(rsa_out);
13292 if (rsal_out != NULL)
13293 PerlMem_free(rsal_out);
13294 set_errno(EVMSERR); set_vaxc_errno(sts);
13298 while ((sts = sys$read(&rab_in))) { /* always true */
13299 if (sts == RMS$_EOF) break;
13300 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13301 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13302 sys$close(&fab_in); sys$close(&fab_out);
13303 PerlMem_free(vmsin);
13304 PerlMem_free(vmsout);
13308 PerlMem_free(esal);
13311 PerlMem_free(rsal);
13312 PerlMem_free(esa_out);
13313 if (esal_out != NULL)
13314 PerlMem_free(esal_out);
13315 PerlMem_free(rsa_out);
13316 if (rsal_out != NULL)
13317 PerlMem_free(rsal_out);
13318 set_errno(EVMSERR); set_vaxc_errno(sts);
13324 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
13325 sys$close(&fab_in); sys$close(&fab_out);
13326 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13328 PerlMem_free(vmsin);
13329 PerlMem_free(vmsout);
13333 PerlMem_free(esal);
13336 PerlMem_free(rsal);
13337 PerlMem_free(esa_out);
13338 if (esal_out != NULL)
13339 PerlMem_free(esal_out);
13340 PerlMem_free(rsa_out);
13341 if (rsal_out != NULL)
13342 PerlMem_free(rsal_out);
13345 set_errno(EVMSERR); set_vaxc_errno(sts);
13351 } /* end of rmscopy() */
13355 /*** The following glue provides 'hooks' to make some of the routines
13356 * from this file available from Perl. These routines are sufficiently
13357 * basic, and are required sufficiently early in the build process,
13358 * that's it's nice to have them available to miniperl as well as the
13359 * full Perl, so they're set up here instead of in an extension. The
13360 * Perl code which handles importation of these names into a given
13361 * package lives in [.VMS]Filespec.pm in @INC.
13365 rmsexpand_fromperl(pTHX_ CV *cv)
13368 char *fspec, *defspec = NULL, *rslt;
13370 int fs_utf8, dfs_utf8;
13374 if (!items || items > 2)
13375 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13376 fspec = SvPV(ST(0),n_a);
13377 fs_utf8 = SvUTF8(ST(0));
13378 if (!fspec || !*fspec) XSRETURN_UNDEF;
13380 defspec = SvPV(ST(1),n_a);
13381 dfs_utf8 = SvUTF8(ST(1));
13383 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13384 ST(0) = sv_newmortal();
13385 if (rslt != NULL) {
13386 sv_usepvn(ST(0),rslt,strlen(rslt));
13395 vmsify_fromperl(pTHX_ CV *cv)
13402 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13403 utf8_fl = SvUTF8(ST(0));
13404 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13405 ST(0) = sv_newmortal();
13406 if (vmsified != NULL) {
13407 sv_usepvn(ST(0),vmsified,strlen(vmsified));
13416 unixify_fromperl(pTHX_ CV *cv)
13423 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13424 utf8_fl = SvUTF8(ST(0));
13425 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13426 ST(0) = sv_newmortal();
13427 if (unixified != NULL) {
13428 sv_usepvn(ST(0),unixified,strlen(unixified));
13437 fileify_fromperl(pTHX_ CV *cv)
13444 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13445 utf8_fl = SvUTF8(ST(0));
13446 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13447 ST(0) = sv_newmortal();
13448 if (fileified != NULL) {
13449 sv_usepvn(ST(0),fileified,strlen(fileified));
13458 pathify_fromperl(pTHX_ CV *cv)
13465 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13466 utf8_fl = SvUTF8(ST(0));
13467 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13468 ST(0) = sv_newmortal();
13469 if (pathified != NULL) {
13470 sv_usepvn(ST(0),pathified,strlen(pathified));
13479 vmspath_fromperl(pTHX_ CV *cv)
13486 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13487 utf8_fl = SvUTF8(ST(0));
13488 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13489 ST(0) = sv_newmortal();
13490 if (vmspath != NULL) {
13491 sv_usepvn(ST(0),vmspath,strlen(vmspath));
13500 unixpath_fromperl(pTHX_ CV *cv)
13507 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13508 utf8_fl = SvUTF8(ST(0));
13509 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13510 ST(0) = sv_newmortal();
13511 if (unixpath != NULL) {
13512 sv_usepvn(ST(0),unixpath,strlen(unixpath));
13521 candelete_fromperl(pTHX_ CV *cv)
13529 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13531 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13532 Newx(fspec, VMS_MAXRSS, char);
13533 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13534 if (SvTYPE(mysv) == SVt_PVGV) {
13535 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13536 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13544 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13545 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13552 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13558 rmscopy_fromperl(pTHX_ CV *cv)
13561 char *inspec, *outspec, *inp, *outp;
13563 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13564 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13565 unsigned long int sts;
13570 if (items < 2 || items > 3)
13571 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13573 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13574 Newx(inspec, VMS_MAXRSS, char);
13575 if (SvTYPE(mysv) == SVt_PVGV) {
13576 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13577 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13578 ST(0) = sv_2mortal(newSViv(0));
13585 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13586 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13587 ST(0) = sv_2mortal(newSViv(0));
13592 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13593 Newx(outspec, VMS_MAXRSS, char);
13594 if (SvTYPE(mysv) == SVt_PVGV) {
13595 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13596 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13597 ST(0) = sv_2mortal(newSViv(0));
13605 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13606 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13607 ST(0) = sv_2mortal(newSViv(0));
13613 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13615 ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
13621 /* The mod2fname is limited to shorter filenames by design, so it should
13622 * not be modified to support longer EFS pathnames
13625 mod2fname(pTHX_ CV *cv)
13628 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13629 workbuff[NAM$C_MAXRSS*1 + 1];
13630 int total_namelen = 3, counter, num_entries;
13631 /* ODS-5 ups this, but we want to be consistent, so... */
13632 int max_name_len = 39;
13633 AV *in_array = (AV *)SvRV(ST(0));
13635 num_entries = av_len(in_array);
13637 /* All the names start with PL_. */
13638 strcpy(ultimate_name, "PL_");
13640 /* Clean up our working buffer */
13641 Zero(work_name, sizeof(work_name), char);
13643 /* Run through the entries and build up a working name */
13644 for(counter = 0; counter <= num_entries; counter++) {
13645 /* If it's not the first name then tack on a __ */
13647 strcat(work_name, "__");
13649 strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13652 /* Check to see if we actually have to bother...*/
13653 if (strlen(work_name) + 3 <= max_name_len) {
13654 strcat(ultimate_name, work_name);
13656 /* It's too darned big, so we need to go strip. We use the same */
13657 /* algorithm as xsubpp does. First, strip out doubled __ */
13658 char *source, *dest, last;
13661 for (source = work_name; *source; source++) {
13662 if (last == *source && last == '_') {
13668 /* Go put it back */
13669 strcpy(work_name, workbuff);
13670 /* Is it still too big? */
13671 if (strlen(work_name) + 3 > max_name_len) {
13672 /* Strip duplicate letters */
13675 for (source = work_name; *source; source++) {
13676 if (last == toupper(*source)) {
13680 last = toupper(*source);
13682 strcpy(work_name, workbuff);
13685 /* Is it *still* too big? */
13686 if (strlen(work_name) + 3 > max_name_len) {
13687 /* Too bad, we truncate */
13688 work_name[max_name_len - 2] = 0;
13690 strcat(ultimate_name, work_name);
13693 /* Okay, return it */
13694 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13699 hushexit_fromperl(pTHX_ CV *cv)
13704 VMSISH_HUSHED = SvTRUE(ST(0));
13706 ST(0) = boolSV(VMSISH_HUSHED);
13712 Perl_vms_start_glob
13713 (pTHX_ SV *tmpglob,
13717 struct vs_str_st *rslt;
13721 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13724 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13725 struct dsc$descriptor_vs rsdsc;
13726 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13727 unsigned long hasver = 0, isunix = 0;
13728 unsigned long int lff_flags = 0;
13730 int vms_old_glob = 1;
13732 if (!SvOK(tmpglob)) {
13733 SETERRNO(ENOENT,RMS$_FNF);
13737 vms_old_glob = !decc_filename_unix_report;
13739 #ifdef VMS_LONGNAME_SUPPORT
13740 lff_flags = LIB$M_FIL_LONG_NAMES;
13742 /* The Newx macro will not allow me to assign a smaller array
13743 * to the rslt pointer, so we will assign it to the begin char pointer
13744 * and then copy the value into the rslt pointer.
13746 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13747 rslt = (struct vs_str_st *)begin;
13749 rstr = &rslt->str[0];
13750 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13751 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13752 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13753 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13755 Newx(vmsspec, VMS_MAXRSS, char);
13757 /* We could find out if there's an explicit dev/dir or version
13758 by peeking into lib$find_file's internal context at
13759 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13760 but that's unsupported, so I don't want to do it now and
13761 have it bite someone in the future. */
13762 /* Fix-me: vms_split_path() is the only way to do this, the
13763 existing method will fail with many legal EFS or UNIX specifications
13766 cp = SvPV(tmpglob,i);
13769 if (cp[i] == ';') hasver = 1;
13770 if (cp[i] == '.') {
13771 if (sts) hasver = 1;
13774 if (cp[i] == '/') {
13775 hasdir = isunix = 1;
13778 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13784 /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13785 if ((hasdir == 0) && decc_filename_unix_report) {
13789 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13790 char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13791 int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13797 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13798 if (!stat_sts && S_ISDIR(st.st_mode)) {
13800 const char * fname;
13803 /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13804 /* path delimiter of ':>]', if so, then the old behavior has */
13805 /* obviously been specificially requested */
13807 fname = SvPVX_const(tmpglob);
13808 fname_len = strlen(fname);
13809 vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13810 if (vms_old_glob || (vms_dir != NULL)) {
13811 wilddsc.dsc$a_pointer = tovmspath_utf8(
13812 SvPVX(tmpglob),vmsspec,NULL);
13813 ok = (wilddsc.dsc$a_pointer != NULL);
13814 /* maybe passed 'foo' rather than '[.foo]', thus not
13818 /* Operate just on the directory, the special stat/fstat for */
13819 /* leaves the fileified specification in the st_devnam */
13821 wilddsc.dsc$a_pointer = st.st_devnam;
13826 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13827 ok = (wilddsc.dsc$a_pointer != NULL);
13830 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13832 /* If not extended character set, replace ? with % */
13833 /* With extended character set, ? is a wildcard single character */
13834 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13837 if (!decc_efs_case_preserve)
13839 } else if (*cp == '%') {
13841 } else if (*cp == '*') {
13847 wv_sts = vms_split_path(
13848 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13849 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13850 &wvs_spec, &wvs_len);
13859 while (ok && $VMS_STATUS_SUCCESS(sts)) {
13860 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13861 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13865 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13866 &dfltdsc,NULL,&rms_sts,&lff_flags);
13867 if (!$VMS_STATUS_SUCCESS(sts))
13870 /* with varying string, 1st word of buffer contains result length */
13871 rstr[rslt->length] = '\0';
13873 /* Find where all the components are */
13874 v_sts = vms_split_path
13889 /* If no version on input, truncate the version on output */
13890 if (!hasver && (vs_len > 0)) {
13897 /* In Unix report mode, remove the ".dir;1" from the name */
13898 /* if it is a real directory */
13899 if (decc_filename_unix_report || decc_efs_charset) {
13900 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13904 ret_sts = flex_lstat(rstr, &statbuf);
13905 if ((ret_sts == 0) &&
13906 S_ISDIR(statbuf.st_mode)) {
13913 /* No version & a null extension on UNIX handling */
13914 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13920 if (!decc_efs_case_preserve) {
13921 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13924 /* Find File treats a Null extension as return all extensions */
13925 /* This is contrary to Perl expectations */
13927 if (wildstar || wildquery || vms_old_glob) {
13928 /* really need to see if the returned file name matched */
13929 /* but for now will assume that it matches */
13932 /* Exact Match requested */
13933 /* How are directories handled? - like a file */
13934 if ((e_len == we_len) && (n_len == wn_len)) {
13938 t1 = strncmp(e_spec, we_spec, e_len);
13942 t1 = strncmp(n_spec, we_spec, n_len);
13953 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13957 /* Start with the name */
13960 strcat(begin,"\n");
13961 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13964 if (cxt) (void)lib$find_file_end(&cxt);
13967 /* Be POSIXish: return the input pattern when no matches */
13968 strcpy(rstr,SvPVX(tmpglob));
13970 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13973 if (ok && sts != RMS$_NMF &&
13974 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13977 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13979 PerlIO_close(tmpfp);
13983 PerlIO_rewind(tmpfp);
13984 IoTYPE(io) = IoTYPE_RDONLY;
13985 IoIFP(io) = fp = tmpfp;
13986 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
13996 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
14000 unixrealpath_fromperl(pTHX_ CV *cv)
14003 char *fspec, *rslt_spec, *rslt;
14006 if (!items || items != 1)
14007 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
14009 fspec = SvPV(ST(0),n_a);
14010 if (!fspec || !*fspec) XSRETURN_UNDEF;
14012 Newx(rslt_spec, VMS_MAXRSS + 1, char);
14013 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
14015 ST(0) = sv_newmortal();
14017 sv_usepvn(ST(0),rslt,strlen(rslt));
14019 Safefree(rslt_spec);
14024 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
14028 vmsrealpath_fromperl(pTHX_ CV *cv)
14031 char *fspec, *rslt_spec, *rslt;
14034 if (!items || items != 1)
14035 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
14037 fspec = SvPV(ST(0),n_a);
14038 if (!fspec || !*fspec) XSRETURN_UNDEF;
14040 Newx(rslt_spec, VMS_MAXRSS + 1, char);
14041 rslt = do_vms_realname(fspec, rslt_spec, NULL);
14043 ST(0) = sv_newmortal();
14045 sv_usepvn(ST(0),rslt,strlen(rslt));
14047 Safefree(rslt_spec);
14053 * A thin wrapper around decc$symlink to make sure we follow the
14054 * standard and do not create a symlink with a zero-length name.
14056 * Also in ODS-2 mode, existing tests assume that the link target
14057 * will be converted to UNIX format.
14059 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
14060 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
14061 if (!link_name || !*link_name) {
14062 SETERRNO(ENOENT, SS$_NOSUCHFILE);
14066 if (decc_efs_charset) {
14067 return symlink(contents, link_name);
14072 /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
14073 /* because in order to work, the symlink target must be in UNIX format */
14075 /* As symbolic links can hold things other than files, we will only do */
14076 /* the conversion in in ODS-2 mode */
14078 utarget = PerlMem_malloc(VMS_MAXRSS + 1);
14079 if (int_tounixspec(contents, utarget, NULL) == NULL) {
14081 /* This should not fail, as an untranslatable filename */
14082 /* should be passed through */
14083 utarget = (char *)contents;
14085 sts = symlink(utarget, link_name);
14086 PerlMem_free(utarget);
14093 #endif /* HAS_SYMLINK */
14095 int do_vms_case_tolerant(void);
14098 case_tolerant_process_fromperl(pTHX_ CV *cv)
14101 ST(0) = boolSV(do_vms_case_tolerant());
14105 #ifdef USE_ITHREADS
14108 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
14109 struct interp_intern *dst)
14111 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
14113 memcpy(dst,src,sizeof(struct interp_intern));
14119 Perl_sys_intern_clear(pTHX)
14124 Perl_sys_intern_init(pTHX)
14126 unsigned int ix = RAND_MAX;
14131 MY_POSIX_EXIT = vms_posix_exit;
14134 MY_INV_RAND_MAX = 1./x;
14138 init_os_extras(void)
14141 char* file = __FILE__;
14142 if (decc_disable_to_vms_logname_translation) {
14143 no_translate_barewords = TRUE;
14145 no_translate_barewords = FALSE;
14148 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
14149 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
14150 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
14151 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
14152 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
14153 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
14154 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
14155 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
14156 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
14157 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
14158 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
14159 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
14160 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
14161 newXSproto("VMS::Filespec::case_tolerant_process",
14162 case_tolerant_process_fromperl,file,"");
14164 store_pipelocs(aTHX); /* will redo any earlier attempts */
14169 #if __CRTL_VER == 80200000
14170 /* This missed getting in to the DECC SDK for 8.2 */
14171 char *realpath(const char *file_name, char * resolved_name, ...);
14174 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
14175 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
14176 * The perl fallback routine to provide realpath() is not as efficient
14180 /* Hack, use old stat() as fastest way of getting ino_t and device */
14181 int decc$stat(const char *name, void * statbuf);
14182 #if !defined(__VAX) && __CRTL_VER >= 80200000
14183 int decc$lstat(const char *name, void * statbuf);
14185 #define decc$lstat decc$stat
14189 /* Realpath is fragile. In 8.3 it does not work if the feature
14190 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
14191 * links are implemented in RMS, not the CRTL. It also can fail if the
14192 * user does not have read/execute access to some of the directories.
14193 * So in order for Do What I Mean mode to work, if realpath() fails,
14194 * fall back to looking up the filename by the device name and FID.
14197 int vms_fid_to_name(char * outname, int outlen,
14198 const char * name, int lstat_flag, mode_t * mode)
14200 #pragma message save
14201 #pragma message disable MISALGNDSTRCT
14202 #pragma message disable MISALGNDMEM
14203 #pragma member_alignment save
14204 #pragma nomember_alignment
14207 unsigned short st_ino[3];
14208 unsigned short old_st_mode;
14209 unsigned long padl[30]; /* plenty of room */
14211 #pragma message restore
14212 #pragma member_alignment restore
14215 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14216 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14221 /* Need to follow the mostly the same rules as flex_stat_int, or we may get
14222 * unexpected answers
14225 fileified = PerlMem_malloc(VMS_MAXRSS);
14226 if (fileified == NULL)
14227 _ckvmssts_noperl(SS$_INSFMEM);
14229 temp_fspec = PerlMem_malloc(VMS_MAXRSS);
14230 if (temp_fspec == NULL)
14231 _ckvmssts_noperl(SS$_INSFMEM);
14234 /* First need to try as a directory */
14235 ret_spec = int_tovmspath(name, temp_fspec, NULL);
14236 if (ret_spec != NULL) {
14237 ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
14238 if (ret_spec != NULL) {
14239 if (lstat_flag == 0)
14240 sts = decc$stat(fileified, &statbuf);
14242 sts = decc$lstat(fileified, &statbuf);
14246 /* Then as a VMS file spec */
14248 ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
14249 if (ret_spec != NULL) {
14250 if (lstat_flag == 0) {
14251 sts = decc$stat(temp_fspec, &statbuf);
14253 sts = decc$lstat(temp_fspec, &statbuf);
14259 /* Next try - allow multiple dots with out EFS CHARSET */
14260 /* The CRTL stat() falls down hard on multi-dot filenames in unix
14261 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
14262 * enable it if it isn't already.
14264 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14265 if (!decc_efs_charset && (decc_efs_charset_index > 0))
14266 decc$feature_set_value(decc_efs_charset_index, 1, 1);
14268 ret_spec = int_tovmspath(name, temp_fspec, NULL);
14269 if (lstat_flag == 0) {
14270 sts = decc$stat(name, &statbuf);
14272 sts = decc$lstat(name, &statbuf);
14274 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14275 if (!decc_efs_charset && (decc_efs_charset_index > 0))
14276 decc$feature_set_value(decc_efs_charset_index, 1, 0);
14281 /* and then because the Perl Unix to VMS conversion is not perfect */
14282 /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
14283 /* characters from filenames so we need to try it as-is */
14285 if (lstat_flag == 0) {
14286 sts = decc$stat(name, &statbuf);
14288 sts = decc$lstat(name, &statbuf);
14295 dvidsc.dsc$a_pointer=statbuf.st_dev;
14296 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
14298 specdsc.dsc$a_pointer = outname;
14299 specdsc.dsc$w_length = outlen-1;
14301 vms_sts = lib$fid_to_name
14302 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
14303 if ($VMS_STATUS_SUCCESS(vms_sts)) {
14304 outname[specdsc.dsc$w_length] = 0;
14306 /* Return the mode */
14308 *mode = statbuf.old_st_mode;
14319 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
14322 char * rslt = NULL;
14325 if (decc_posix_compliant_pathnames > 0 ) {
14326 /* realpath currently only works if posix compliant pathnames are
14327 * enabled. It may start working when they are not, but in that
14328 * case we still want the fallback behavior for backwards compatibility
14330 rslt = realpath(filespec, outbuf);
14334 if (rslt == NULL) {
14336 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14337 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14341 /* Fall back to fid_to_name */
14343 Newx(vms_spec, VMS_MAXRSS + 1, char);
14345 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
14349 /* Now need to trim the version off */
14350 sts = vms_split_path
14370 /* Trim off the version */
14371 int file_len = v_len + r_len + d_len + n_len + e_len;
14372 vms_spec[file_len] = 0;
14374 /* Trim off the .DIR if this is a directory */
14375 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
14376 if (S_ISDIR(my_mode)) {
14382 /* Drop NULL extensions on UNIX file specification */
14383 if ((e_len == 1) && decc_readdir_dropdotnotype) {
14388 /* The result is expected to be in UNIX format */
14389 rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14391 /* Downcase if input had any lower case letters and
14392 * case preservation is not in effect.
14394 if (!decc_efs_case_preserve) {
14395 for (cp = filespec; *cp; cp++)
14396 if (islower(*cp)) { haslower = 1; break; }
14398 if (haslower) __mystrtolower(rslt);
14403 /* Now for some hacks to deal with backwards and forward */
14405 if (!decc_efs_charset) {
14407 /* 1. ODS-2 mode wants to do a syntax only translation */
14408 rslt = int_rmsexpand(filespec, outbuf,
14409 NULL, 0, NULL, utf8_fl);
14412 if (decc_filename_unix_report) {
14414 char * vms_dir_name;
14417 /* 2. ODS-5 / UNIX report mode should return a failure */
14418 /* if the parent directory also does not exist */
14419 /* Otherwise, get the real path for the parent */
14420 /* and add the child to it.
14422 /* basename / dirname only available for VMS 7.0+ */
14423 /* So we may need to implement them as common routines */
14425 Newx(dir_name, VMS_MAXRSS + 1, char);
14426 Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14427 dir_name[0] = '\0';
14430 /* First try a VMS parse */
14431 sts = vms_split_path
14449 int dir_len = v_len + r_len + d_len + n_len;
14451 strncpy(dir_name, filespec, dir_len);
14452 dir_name[dir_len] = '\0';
14453 file_name = (char *)&filespec[dir_len + 1];
14456 /* This must be UNIX */
14459 tchar = strrchr(filespec, '/');
14461 if (tchar != NULL) {
14462 int dir_len = tchar - filespec;
14463 strncpy(dir_name, filespec, dir_len);
14464 dir_name[dir_len] = '\0';
14465 file_name = (char *) &filespec[dir_len + 1];
14469 /* Dir name is defaulted */
14470 if (dir_name[0] == 0) {
14472 dir_name[1] = '\0';
14475 /* Need realpath for the directory */
14476 sts = vms_fid_to_name(vms_dir_name,
14478 dir_name, 0, NULL);
14481 /* Now need to pathify it.
14482 char *tdir = int_pathify_dirspec(vms_dir_name,
14485 /* And now add the original filespec to it */
14486 if (file_name != NULL) {
14487 strcat(outbuf, file_name);
14491 Safefree(vms_dir_name);
14492 Safefree(dir_name);
14496 Safefree(vms_spec);
14502 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14505 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14506 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14509 /* Fall back to fid_to_name */
14511 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
14518 /* Now need to trim the version off */
14519 sts = vms_split_path
14539 /* Trim off the version */
14540 int file_len = v_len + r_len + d_len + n_len + e_len;
14541 outbuf[file_len] = 0;
14543 /* Downcase if input had any lower case letters and
14544 * case preservation is not in effect.
14546 if (!decc_efs_case_preserve) {
14547 for (cp = filespec; *cp; cp++)
14548 if (islower(*cp)) { haslower = 1; break; }
14550 if (haslower) __mystrtolower(outbuf);
14559 /* External entry points */
14560 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14561 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14563 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14564 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14566 /* case_tolerant */
14568 /*{{{int do_vms_case_tolerant(void)*/
14569 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14570 * controlled by a process setting.
14572 int do_vms_case_tolerant(void)
14574 return vms_process_case_tolerant;
14577 /* External entry points */
14578 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14579 int Perl_vms_case_tolerant(void)
14580 { return do_vms_case_tolerant(); }
14582 int Perl_vms_case_tolerant(void)
14583 { return vms_process_case_tolerant; }
14587 /* Start of DECC RTL Feature handling */
14589 static int sys_trnlnm
14590 (const char * logname,
14594 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14595 const unsigned long attr = LNM$M_CASE_BLIND;
14596 struct dsc$descriptor_s name_dsc;
14598 unsigned short result;
14599 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14602 name_dsc.dsc$w_length = strlen(logname);
14603 name_dsc.dsc$a_pointer = (char *)logname;
14604 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14605 name_dsc.dsc$b_class = DSC$K_CLASS_S;
14607 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14609 if ($VMS_STATUS_SUCCESS(status)) {
14611 /* Null terminate and return the string */
14612 /*--------------------------------------*/
14619 static int sys_crelnm
14620 (const char * logname,
14621 const char * value)
14624 const char * proc_table = "LNM$PROCESS_TABLE";
14625 struct dsc$descriptor_s proc_table_dsc;
14626 struct dsc$descriptor_s logname_dsc;
14627 struct itmlst_3 item_list[2];
14629 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14630 proc_table_dsc.dsc$w_length = strlen(proc_table);
14631 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14632 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14634 logname_dsc.dsc$a_pointer = (char *) logname;
14635 logname_dsc.dsc$w_length = strlen(logname);
14636 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14637 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14639 item_list[0].buflen = strlen(value);
14640 item_list[0].itmcode = LNM$_STRING;
14641 item_list[0].bufadr = (char *)value;
14642 item_list[0].retlen = NULL;
14644 item_list[1].buflen = 0;
14645 item_list[1].itmcode = 0;
14647 ret_val = sys$crelnm
14649 (const struct dsc$descriptor_s *)&proc_table_dsc,
14650 (const struct dsc$descriptor_s *)&logname_dsc,
14652 (const struct item_list_3 *) item_list);
14657 /* C RTL Feature settings */
14659 static int set_features
14660 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
14661 int (* cli_routine)(void), /* Not documented */
14662 void *image_info) /* Not documented */
14668 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14669 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14670 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14671 unsigned long case_perm;
14672 unsigned long case_image;
14675 /* Allow an exception to bring Perl into the VMS debugger */
14676 vms_debug_on_exception = 0;
14677 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14678 if ($VMS_STATUS_SUCCESS(status)) {
14679 val_str[0] = _toupper(val_str[0]);
14680 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14681 vms_debug_on_exception = 1;
14683 vms_debug_on_exception = 0;
14686 /* Debug unix/vms file translation routines */
14687 vms_debug_fileify = 0;
14688 status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14689 if ($VMS_STATUS_SUCCESS(status)) {
14690 val_str[0] = _toupper(val_str[0]);
14691 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14692 vms_debug_fileify = 1;
14694 vms_debug_fileify = 0;
14698 /* Historically PERL has been doing vmsify / stat differently than */
14699 /* the CRTL. In particular, under some conditions the CRTL will */
14700 /* remove some illegal characters like spaces from filenames */
14701 /* resulting in some differences. The stat()/lstat() wrapper has */
14702 /* been reporting such file names as invalid and fails to stat them */
14703 /* fixing this bug so that stat()/lstat() accept these like the */
14704 /* CRTL does will result in several tests failing. */
14705 /* This should really be fixed, but for now, set up a feature to */
14706 /* enable it so that the impact can be studied. */
14707 vms_bug_stat_filename = 0;
14708 status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14709 if ($VMS_STATUS_SUCCESS(status)) {
14710 val_str[0] = _toupper(val_str[0]);
14711 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14712 vms_bug_stat_filename = 1;
14714 vms_bug_stat_filename = 0;
14718 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14719 vms_vtf7_filenames = 0;
14720 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14721 if ($VMS_STATUS_SUCCESS(status)) {
14722 val_str[0] = _toupper(val_str[0]);
14723 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14724 vms_vtf7_filenames = 1;
14726 vms_vtf7_filenames = 0;
14729 /* unlink all versions on unlink() or rename() */
14730 vms_unlink_all_versions = 0;
14731 status = sys_trnlnm
14732 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14733 if ($VMS_STATUS_SUCCESS(status)) {
14734 val_str[0] = _toupper(val_str[0]);
14735 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14736 vms_unlink_all_versions = 1;
14738 vms_unlink_all_versions = 0;
14741 /* Dectect running under GNV Bash or other UNIX like shell */
14742 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14743 gnv_unix_shell = 0;
14744 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14745 if ($VMS_STATUS_SUCCESS(status)) {
14746 gnv_unix_shell = 1;
14747 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14748 set_feature_default("DECC$EFS_CHARSET", 1);
14749 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14750 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14751 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14752 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14753 vms_unlink_all_versions = 1;
14754 vms_posix_exit = 1;
14758 /* hacks to see if known bugs are still present for testing */
14760 /* PCP mode requires creating /dev/null special device file */
14761 decc_bug_devnull = 0;
14762 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14763 if ($VMS_STATUS_SUCCESS(status)) {
14764 val_str[0] = _toupper(val_str[0]);
14765 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14766 decc_bug_devnull = 1;
14768 decc_bug_devnull = 0;
14771 /* UNIX directory names with no paths are broken in a lot of places */
14772 decc_dir_barename = 1;
14773 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14774 if ($VMS_STATUS_SUCCESS(status)) {
14775 val_str[0] = _toupper(val_str[0]);
14776 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14777 decc_dir_barename = 1;
14779 decc_dir_barename = 0;
14782 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14783 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14785 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14786 if (decc_disable_to_vms_logname_translation < 0)
14787 decc_disable_to_vms_logname_translation = 0;
14790 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14792 decc_efs_case_preserve = decc$feature_get_value(s, 1);
14793 if (decc_efs_case_preserve < 0)
14794 decc_efs_case_preserve = 0;
14797 s = decc$feature_get_index("DECC$EFS_CHARSET");
14798 decc_efs_charset_index = s;
14800 decc_efs_charset = decc$feature_get_value(s, 1);
14801 if (decc_efs_charset < 0)
14802 decc_efs_charset = 0;
14805 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14807 decc_filename_unix_report = decc$feature_get_value(s, 1);
14808 if (decc_filename_unix_report > 0) {
14809 decc_filename_unix_report = 1;
14810 vms_posix_exit = 1;
14813 decc_filename_unix_report = 0;
14816 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14818 decc_filename_unix_only = decc$feature_get_value(s, 1);
14819 if (decc_filename_unix_only > 0) {
14820 decc_filename_unix_only = 1;
14823 decc_filename_unix_only = 0;
14827 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14829 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14830 if (decc_filename_unix_no_version < 0)
14831 decc_filename_unix_no_version = 0;
14834 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14836 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14837 if (decc_readdir_dropdotnotype < 0)
14838 decc_readdir_dropdotnotype = 0;
14841 #if __CRTL_VER >= 80200000
14842 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14844 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14845 if (decc_posix_compliant_pathnames < 0)
14846 decc_posix_compliant_pathnames = 0;
14847 if (decc_posix_compliant_pathnames > 4)
14848 decc_posix_compliant_pathnames = 0;
14853 status = sys_trnlnm
14854 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14855 if ($VMS_STATUS_SUCCESS(status)) {
14856 val_str[0] = _toupper(val_str[0]);
14857 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14858 decc_disable_to_vms_logname_translation = 1;
14863 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14864 if ($VMS_STATUS_SUCCESS(status)) {
14865 val_str[0] = _toupper(val_str[0]);
14866 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14867 decc_efs_case_preserve = 1;
14872 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14873 if ($VMS_STATUS_SUCCESS(status)) {
14874 val_str[0] = _toupper(val_str[0]);
14875 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14876 decc_filename_unix_report = 1;
14879 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14880 if ($VMS_STATUS_SUCCESS(status)) {
14881 val_str[0] = _toupper(val_str[0]);
14882 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14883 decc_filename_unix_only = 1;
14884 decc_filename_unix_report = 1;
14887 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14888 if ($VMS_STATUS_SUCCESS(status)) {
14889 val_str[0] = _toupper(val_str[0]);
14890 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14891 decc_filename_unix_no_version = 1;
14894 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14895 if ($VMS_STATUS_SUCCESS(status)) {
14896 val_str[0] = _toupper(val_str[0]);
14897 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14898 decc_readdir_dropdotnotype = 1;
14903 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14905 /* Report true case tolerance */
14906 /*----------------------------*/
14907 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14908 if (!$VMS_STATUS_SUCCESS(status))
14909 case_perm = PPROP$K_CASE_BLIND;
14910 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14911 if (!$VMS_STATUS_SUCCESS(status))
14912 case_image = PPROP$K_CASE_BLIND;
14913 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14914 (case_image == PPROP$K_CASE_SENSITIVE))
14915 vms_process_case_tolerant = 0;
14919 /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
14920 /* for strict backward compatibilty */
14921 status = sys_trnlnm
14922 ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14923 if ($VMS_STATUS_SUCCESS(status)) {
14924 val_str[0] = _toupper(val_str[0]);
14925 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14926 vms_posix_exit = 1;
14928 vms_posix_exit = 0;
14932 /* CRTL can be initialized past this point, but not before. */
14933 /* DECC$CRTL_INIT(); */
14940 #pragma extern_model save
14941 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14942 const __align (LONGWORD) int spare[8] = {0};
14944 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14945 #if __DECC_VER >= 60560002
14946 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14948 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14950 #endif /* __DECC */
14952 const long vms_cc_features = (const long)set_features;
14955 ** Force a reference to LIB$INITIALIZE to ensure it
14956 ** exists in the image.
14958 int lib$initialize(void);
14960 #pragma extern_model strict_refdef
14962 int lib_init_ref = (int) lib$initialize;
14965 #pragma extern_model restore