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)
3081 && PL_perlio_fd_refcnt
3084 PerlIO_flush(info->fp);
3086 fflush((FILE *)info->fp);
3092 next we try sending an EOF...ignore if doesn't work, make sure we
3100 _ckvmssts_noperl(sys$setast(0));
3101 if (info->in && !info->in->shut_on_empty) {
3102 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3107 _ckvmssts_noperl(sys$setast(1));
3111 /* wait for EOF to have effect, up to ~ 30 sec [default] */
3113 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3118 _ckvmssts_noperl(sys$setast(0));
3119 if (info->waiting && info->done)
3121 nwait += info->waiting;
3122 _ckvmssts_noperl(sys$setast(1));
3132 _ckvmssts_noperl(sys$setast(0));
3133 if (!info->done) { /* Tap them gently on the shoulder . . .*/
3134 sts = sys$forcex(&info->pid,0,&abort);
3135 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3138 _ckvmssts_noperl(sys$setast(1));
3142 /* again, wait for effect */
3144 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3149 _ckvmssts_noperl(sys$setast(0));
3150 if (info->waiting && info->done)
3152 nwait += info->waiting;
3153 _ckvmssts_noperl(sys$setast(1));
3162 _ckvmssts_noperl(sys$setast(0));
3163 if (!info->done) { /* We tried to be nice . . . */
3164 sts = sys$delprc(&info->pid,0);
3165 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3166 info->done = 1; /* sys$delprc is as done as we're going to get. */
3168 _ckvmssts_noperl(sys$setast(1));
3174 #if defined(PERL_IMPLICIT_CONTEXT)
3175 /* We need to use the Perl context of the thread that created */
3178 if (open_pipes->err)
3179 aTHX = open_pipes->err->thx;
3180 else if (open_pipes->out)
3181 aTHX = open_pipes->out->thx;
3182 else if (open_pipes->in)
3183 aTHX = open_pipes->in->thx;
3185 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3186 else if (!(sts & 1)) retsts = sts;
3191 static struct exit_control_block pipe_exitblock =
3192 {(struct exit_control_block *) 0,
3193 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3195 static void pipe_mbxtofd_ast(pPipe p);
3196 static void pipe_tochild1_ast(pPipe p);
3197 static void pipe_tochild2_ast(pPipe p);
3200 popen_completion_ast(pInfo info)
3202 pInfo i = open_pipes;
3207 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3208 closed_list[closed_index].pid = info->pid;
3209 closed_list[closed_index].completion = info->completion;
3211 if (closed_index == NKEEPCLOSED)
3216 if (i == info) break;
3219 if (!i) return; /* unlinked, probably freed too */
3224 Writing to subprocess ...
3225 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3227 chan_out may be waiting for "done" flag, or hung waiting
3228 for i/o completion to child...cancel the i/o. This will
3229 put it into "snarf mode" (done but no EOF yet) that discards
3232 Output from subprocess (stdout, stderr) needs to be flushed and
3233 shut down. We try sending an EOF, but if the mbx is full the pipe
3234 routine should still catch the "shut_on_empty" flag, telling it to
3235 use immediate-style reads so that "mbx empty" -> EOF.
3239 if (info->in && !info->in_done) { /* only for mode=w */
3240 if (info->in->shut_on_empty && info->in->need_wake) {
3241 info->in->need_wake = FALSE;
3242 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3244 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3248 if (info->out && !info->out_done) { /* were we also piping output? */
3249 info->out->shut_on_empty = TRUE;
3250 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3251 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3252 _ckvmssts_noperl(iss);
3255 if (info->err && !info->err_done) { /* we were piping stderr */
3256 info->err->shut_on_empty = TRUE;
3257 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3258 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3259 _ckvmssts_noperl(iss);
3261 _ckvmssts_noperl(sys$setef(pipe_ef));
3265 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3266 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3269 we actually differ from vmstrnenv since we use this to
3270 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3271 are pointing to the same thing
3274 static unsigned short
3275 popen_translate(pTHX_ char *logical, char *result)
3278 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3279 $DESCRIPTOR(d_log,"");
3281 unsigned short length;
3282 unsigned short code;
3284 unsigned short *retlenaddr;
3286 unsigned short l, ifi;
3288 d_log.dsc$a_pointer = logical;
3289 d_log.dsc$w_length = strlen(logical);
3291 itmlst[0].code = LNM$_STRING;
3292 itmlst[0].length = 255;
3293 itmlst[0].buffer_addr = result;
3294 itmlst[0].retlenaddr = &l;
3297 itmlst[1].length = 0;
3298 itmlst[1].buffer_addr = 0;
3299 itmlst[1].retlenaddr = 0;
3301 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3302 if (iss == SS$_NOLOGNAM) {
3306 if (!(iss&1)) lib$signal(iss);
3309 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3310 strip it off and return the ifi, if any
3313 if (result[0] == 0x1b && result[1] == 0x00) {
3314 memmove(&ifi,result+2,2);
3315 strcpy(result,result+4);
3317 return ifi; /* this is the RMS internal file id */
3320 static void pipe_infromchild_ast(pPipe p);
3323 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3324 inside an AST routine without worrying about reentrancy and which Perl
3325 memory allocator is being used.
3327 We read data and queue up the buffers, then spit them out one at a
3328 time to the output mailbox when the output mailbox is ready for one.
3331 #define INITIAL_TOCHILDQUEUE 2
3334 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3338 char mbx1[64], mbx2[64];
3339 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3340 DSC$K_CLASS_S, mbx1},
3341 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3342 DSC$K_CLASS_S, mbx2};
3343 unsigned int dviitm = DVI$_DEVBUFSIZ;
3347 _ckvmssts_noperl(lib$get_vm(&n, &p));
3349 create_mbx(&p->chan_in , &d_mbx1);
3350 create_mbx(&p->chan_out, &d_mbx2);
3351 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3354 p->shut_on_empty = FALSE;
3355 p->need_wake = FALSE;
3358 p->iosb.status = SS$_NORMAL;
3359 p->iosb2.status = SS$_NORMAL;
3365 #ifdef PERL_IMPLICIT_CONTEXT
3369 n = sizeof(CBuf) + p->bufsize;
3371 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3372 _ckvmssts_noperl(lib$get_vm(&n, &b));
3373 b->buf = (char *) b + sizeof(CBuf);
3374 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3377 pipe_tochild2_ast(p);
3378 pipe_tochild1_ast(p);
3384 /* reads the MBX Perl is writing, and queues */
3387 pipe_tochild1_ast(pPipe p)
3390 int iss = p->iosb.status;
3391 int eof = (iss == SS$_ENDOFFILE);
3393 #ifdef PERL_IMPLICIT_CONTEXT
3399 p->shut_on_empty = TRUE;
3401 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3403 _ckvmssts_noperl(iss);
3407 b->size = p->iosb.count;
3408 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3410 p->need_wake = FALSE;
3411 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3414 p->retry = 1; /* initial call */
3417 if (eof) { /* flush the free queue, return when done */
3418 int n = sizeof(CBuf) + p->bufsize;
3420 iss = lib$remqti(&p->free, &b);
3421 if (iss == LIB$_QUEWASEMP) return;
3422 _ckvmssts_noperl(iss);
3423 _ckvmssts_noperl(lib$free_vm(&n, &b));
3427 iss = lib$remqti(&p->free, &b);
3428 if (iss == LIB$_QUEWASEMP) {
3429 int n = sizeof(CBuf) + p->bufsize;
3430 _ckvmssts_noperl(lib$get_vm(&n, &b));
3431 b->buf = (char *) b + sizeof(CBuf);
3433 _ckvmssts_noperl(iss);
3437 iss = sys$qio(0,p->chan_in,
3438 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3440 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3441 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3442 _ckvmssts_noperl(iss);
3446 /* writes queued buffers to output, waits for each to complete before
3450 pipe_tochild2_ast(pPipe p)
3453 int iss = p->iosb2.status;
3454 int n = sizeof(CBuf) + p->bufsize;
3455 int done = (p->info && p->info->done) ||
3456 iss == SS$_CANCEL || iss == SS$_ABORT;
3457 #if defined(PERL_IMPLICIT_CONTEXT)
3462 if (p->type) { /* type=1 has old buffer, dispose */
3463 if (p->shut_on_empty) {
3464 _ckvmssts_noperl(lib$free_vm(&n, &b));
3466 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3471 iss = lib$remqti(&p->wait, &b);
3472 if (iss == LIB$_QUEWASEMP) {
3473 if (p->shut_on_empty) {
3475 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3476 *p->pipe_done = TRUE;
3477 _ckvmssts_noperl(sys$setef(pipe_ef));
3479 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3480 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3484 p->need_wake = TRUE;
3487 _ckvmssts_noperl(iss);
3494 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3495 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3497 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3498 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3507 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3510 char mbx1[64], mbx2[64];
3511 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3512 DSC$K_CLASS_S, mbx1},
3513 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3514 DSC$K_CLASS_S, mbx2};
3515 unsigned int dviitm = DVI$_DEVBUFSIZ;
3517 int n = sizeof(Pipe);
3518 _ckvmssts_noperl(lib$get_vm(&n, &p));
3519 create_mbx(&p->chan_in , &d_mbx1);
3520 create_mbx(&p->chan_out, &d_mbx2);
3522 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3523 n = p->bufsize * sizeof(char);
3524 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3525 p->shut_on_empty = FALSE;
3528 p->iosb.status = SS$_NORMAL;
3529 #if defined(PERL_IMPLICIT_CONTEXT)
3532 pipe_infromchild_ast(p);
3540 pipe_infromchild_ast(pPipe p)
3542 int iss = p->iosb.status;
3543 int eof = (iss == SS$_ENDOFFILE);
3544 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3545 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3546 #if defined(PERL_IMPLICIT_CONTEXT)
3550 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3551 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3556 input shutdown if EOF from self (done or shut_on_empty)
3557 output shutdown if closing flag set (my_pclose)
3558 send data/eof from child or eof from self
3559 otherwise, re-read (snarf of data from child)
3564 if (myeof && p->chan_in) { /* input shutdown */
3565 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3570 if (myeof || kideof) { /* pass EOF to parent */
3571 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3572 pipe_infromchild_ast, p,
3575 } else if (eof) { /* eat EOF --- fall through to read*/
3577 } else { /* transmit data */
3578 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3579 pipe_infromchild_ast,p,
3580 p->buf, p->iosb.count, 0, 0, 0, 0));
3586 /* everything shut? flag as done */
3588 if (!p->chan_in && !p->chan_out) {
3589 *p->pipe_done = TRUE;
3590 _ckvmssts_noperl(sys$setef(pipe_ef));
3594 /* write completed (or read, if snarfing from child)
3595 if still have input active,
3596 queue read...immediate mode if shut_on_empty so we get EOF if empty
3598 check if Perl reading, generate EOFs as needed
3604 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3605 pipe_infromchild_ast,p,
3606 p->buf, p->bufsize, 0, 0, 0, 0);
3607 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3608 _ckvmssts_noperl(iss);
3609 } else { /* send EOFs for extra reads */
3610 p->iosb.status = SS$_ENDOFFILE;
3611 p->iosb.dvispec = 0;
3612 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3614 pipe_infromchild_ast, p, 0, 0, 0, 0));
3620 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3624 unsigned long dviitm = DVI$_DEVBUFSIZ;
3626 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3627 DSC$K_CLASS_S, mbx};
3628 int n = sizeof(Pipe);
3630 /* things like terminals and mbx's don't need this filter */
3631 if (fd && fstat(fd,&s) == 0) {
3632 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3634 unsigned short dev_len;
3635 struct dsc$descriptor_s d_dev;
3637 struct item_list_3 items[3];
3639 unsigned short dvi_iosb[4];
3641 cptr = getname(fd, out, 1);
3642 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3643 d_dev.dsc$a_pointer = out;
3644 d_dev.dsc$w_length = strlen(out);
3645 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3646 d_dev.dsc$b_class = DSC$K_CLASS_S;
3649 items[0].code = DVI$_DEVCHAR;
3650 items[0].bufadr = &devchar;
3651 items[0].retadr = NULL;
3653 items[1].code = DVI$_FULLDEVNAM;
3654 items[1].bufadr = device;
3655 items[1].retadr = &dev_len;
3659 status = sys$getdviw
3660 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3661 _ckvmssts_noperl(status);
3662 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3663 device[dev_len] = 0;
3665 if (!(devchar & DEV$M_DIR)) {
3666 strcpy(out, device);
3672 _ckvmssts_noperl(lib$get_vm(&n, &p));
3673 p->fd_out = dup(fd);
3674 create_mbx(&p->chan_in, &d_mbx);
3675 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3676 n = (p->bufsize+1) * sizeof(char);
3677 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3678 p->shut_on_empty = FALSE;
3683 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3684 pipe_mbxtofd_ast, p,
3685 p->buf, p->bufsize, 0, 0, 0, 0));
3691 pipe_mbxtofd_ast(pPipe p)
3693 int iss = p->iosb.status;
3694 int done = p->info->done;
3696 int eof = (iss == SS$_ENDOFFILE);
3697 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3698 int err = !(iss&1) && !eof;
3699 #if defined(PERL_IMPLICIT_CONTEXT)
3703 if (done && myeof) { /* end piping */
3705 sys$dassgn(p->chan_in);
3706 *p->pipe_done = TRUE;
3707 _ckvmssts_noperl(sys$setef(pipe_ef));
3711 if (!err && !eof) { /* good data to send to file */
3712 p->buf[p->iosb.count] = '\n';
3713 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3716 if (p->retry < MAX_RETRY) {
3717 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3723 _ckvmssts_noperl(iss);
3727 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3728 pipe_mbxtofd_ast, p,
3729 p->buf, p->bufsize, 0, 0, 0, 0);
3730 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3731 _ckvmssts_noperl(iss);
3735 typedef struct _pipeloc PLOC;
3736 typedef struct _pipeloc* pPLOC;
3740 char dir[NAM$C_MAXRSS+1];
3742 static pPLOC head_PLOC = 0;
3745 free_pipelocs(pTHX_ void *head)
3748 pPLOC *pHead = (pPLOC *)head;
3760 store_pipelocs(pTHX)
3769 char temp[NAM$C_MAXRSS+1];
3773 free_pipelocs(aTHX_ &head_PLOC);
3775 /* the . directory from @INC comes last */
3777 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3778 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3779 p->next = head_PLOC;
3781 strcpy(p->dir,"./");
3783 /* get the directory from $^X */
3785 unixdir = PerlMem_malloc(VMS_MAXRSS);
3786 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3788 #ifdef PERL_IMPLICIT_CONTEXT
3789 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3791 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3793 strcpy(temp, PL_origargv[0]);
3794 x = strrchr(temp,']');
3796 x = strrchr(temp,'>');
3798 /* It could be a UNIX path */
3799 x = strrchr(temp,'/');
3805 /* Got a bare name, so use default directory */
3810 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3811 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3812 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3813 p->next = head_PLOC;
3815 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3816 p->dir[NAM$C_MAXRSS] = '\0';
3820 /* reverse order of @INC entries, skip "." since entered above */
3822 #ifdef PERL_IMPLICIT_CONTEXT
3825 if (PL_incgv) av = GvAVn(PL_incgv);
3827 for (i = 0; av && i <= AvFILL(av); i++) {
3828 dirsv = *av_fetch(av,i,TRUE);
3830 if (SvROK(dirsv)) continue;
3831 dir = SvPVx(dirsv,n_a);
3832 if (strcmp(dir,".") == 0) continue;
3833 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3836 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3837 p->next = head_PLOC;
3839 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3840 p->dir[NAM$C_MAXRSS] = '\0';
3843 /* most likely spot (ARCHLIB) put first in the list */
3846 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3847 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3848 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3849 p->next = head_PLOC;
3851 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3852 p->dir[NAM$C_MAXRSS] = '\0';
3855 PerlMem_free(unixdir);
3859 Perl_cando_by_name_int
3860 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3861 #if !defined(PERL_IMPLICIT_CONTEXT)
3862 #define cando_by_name_int Perl_cando_by_name_int
3864 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3870 static int vmspipe_file_status = 0;
3871 static char vmspipe_file[NAM$C_MAXRSS+1];
3873 /* already found? Check and use ... need read+execute permission */
3875 if (vmspipe_file_status == 1) {
3876 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3877 && cando_by_name_int
3878 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3879 return vmspipe_file;
3881 vmspipe_file_status = 0;
3884 /* scan through stored @INC, $^X */
3886 if (vmspipe_file_status == 0) {
3887 char file[NAM$C_MAXRSS+1];
3888 pPLOC p = head_PLOC;
3893 strcpy(file, p->dir);
3894 dirlen = strlen(file);
3895 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3896 file[NAM$C_MAXRSS] = '\0';
3899 exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3900 if (!exp_res) continue;
3902 if (cando_by_name_int
3903 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3904 && cando_by_name_int
3905 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3906 vmspipe_file_status = 1;
3907 return vmspipe_file;
3910 vmspipe_file_status = -1; /* failed, use tempfiles */
3917 vmspipe_tempfile(pTHX)
3919 char file[NAM$C_MAXRSS+1];
3921 static int index = 0;
3925 /* create a tempfile */
3927 /* we can't go from W, shr=get to R, shr=get without
3928 an intermediate vulnerable state, so don't bother trying...
3930 and lib$spawn doesn't shr=put, so have to close the write
3932 So... match up the creation date/time and the FID to
3933 make sure we're dealing with the same file
3938 if (!decc_filename_unix_only) {
3939 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3940 fp = fopen(file,"w");
3942 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3943 fp = fopen(file,"w");
3945 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3946 fp = fopen(file,"w");
3951 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3952 fp = fopen(file,"w");
3954 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3955 fp = fopen(file,"w");
3957 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3958 fp = fopen(file,"w");
3962 if (!fp) return 0; /* we're hosed */
3964 fprintf(fp,"$! 'f$verify(0)'\n");
3965 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3966 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3967 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3968 fprintf(fp,"$ perl_on = \"set noon\"\n");
3969 fprintf(fp,"$ perl_exit = \"exit\"\n");
3970 fprintf(fp,"$ perl_del = \"delete\"\n");
3971 fprintf(fp,"$ pif = \"if\"\n");
3972 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3973 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3974 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3975 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3976 fprintf(fp,"$! --- build command line to get max possible length\n");
3977 fprintf(fp,"$c=perl_popen_cmd0\n");
3978 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3979 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3980 fprintf(fp,"$x=perl_popen_cmd3\n");
3981 fprintf(fp,"$c=c+x\n");
3982 fprintf(fp,"$ perl_on\n");
3983 fprintf(fp,"$ 'c'\n");
3984 fprintf(fp,"$ perl_status = $STATUS\n");
3985 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3986 fprintf(fp,"$ perl_exit 'perl_status'\n");
3989 fgetname(fp, file, 1);
3990 fstat(fileno(fp), &s0.crtl_stat);
3993 if (decc_filename_unix_only)
3994 int_tounixspec(file, file, NULL);
3995 fp = fopen(file,"r","shr=get");
3997 fstat(fileno(fp), &s1.crtl_stat);
3999 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
4000 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
4009 static int vms_is_syscommand_xterm(void)
4011 const static struct dsc$descriptor_s syscommand_dsc =
4012 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
4014 const static struct dsc$descriptor_s decwdisplay_dsc =
4015 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
4017 struct item_list_3 items[2];
4018 unsigned short dvi_iosb[4];
4019 unsigned long devchar;
4020 unsigned long devclass;
4023 /* Very simple check to guess if sys$command is a decterm? */
4024 /* First see if the DECW$DISPLAY: device exists */
4026 items[0].code = DVI$_DEVCHAR;
4027 items[0].bufadr = &devchar;
4028 items[0].retadr = NULL;
4032 status = sys$getdviw
4033 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
4035 if ($VMS_STATUS_SUCCESS(status)) {
4036 status = dvi_iosb[0];
4039 if (!$VMS_STATUS_SUCCESS(status)) {
4040 SETERRNO(EVMSERR, status);
4044 /* If it does, then for now assume that we are on a workstation */
4045 /* Now verify that SYS$COMMAND is a terminal */
4046 /* for creating the debugger DECTerm */
4049 items[0].code = DVI$_DEVCLASS;
4050 items[0].bufadr = &devclass;
4051 items[0].retadr = NULL;
4055 status = sys$getdviw
4056 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
4058 if ($VMS_STATUS_SUCCESS(status)) {
4059 status = dvi_iosb[0];
4062 if (!$VMS_STATUS_SUCCESS(status)) {
4063 SETERRNO(EVMSERR, status);
4067 if (devclass == DC$_TERM) {
4074 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
4075 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
4080 char device_name[65];
4081 unsigned short device_name_len;
4082 struct dsc$descriptor_s customization_dsc;
4083 struct dsc$descriptor_s device_name_dsc;
4086 char customization[200];
4090 unsigned short p_chan;
4092 unsigned short iosb[4];
4093 struct item_list_3 items[2];
4094 const char * cust_str =
4095 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4096 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4097 DSC$K_CLASS_S, mbx1};
4099 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4100 /*---------------------------------------*/
4101 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4104 /* Make sure that this is from the Perl debugger */
4105 ret_char = strstr(cmd," xterm ");
4106 if (ret_char == NULL)
4108 cptr = ret_char + 7;
4109 ret_char = strstr(cmd,"tty");
4110 if (ret_char == NULL)
4112 ret_char = strstr(cmd,"sleep");
4113 if (ret_char == NULL)
4116 if (decw_term_port == 0) {
4117 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4118 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4119 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4121 status = lib$find_image_symbol
4123 &decw_term_port_dsc,
4124 (void *)&decw_term_port,
4128 /* Try again with the other image name */
4129 if (!$VMS_STATUS_SUCCESS(status)) {
4131 status = lib$find_image_symbol
4133 &decw_term_port_dsc,
4134 (void *)&decw_term_port,
4143 /* No decw$term_port, give it up */
4144 if (!$VMS_STATUS_SUCCESS(status))
4147 /* Are we on a workstation? */
4148 /* to do: capture the rows / columns and pass their properties */
4149 ret_stat = vms_is_syscommand_xterm();
4153 /* Make the title: */
4154 ret_char = strstr(cptr,"-title");
4155 if (ret_char != NULL) {
4156 while ((*cptr != 0) && (*cptr != '\"')) {
4162 while ((*cptr != 0) && (*cptr != '\"')) {
4175 strcpy(title,"Perl Debug DECTerm");
4177 sprintf(customization, cust_str, title);
4179 customization_dsc.dsc$a_pointer = customization;
4180 customization_dsc.dsc$w_length = strlen(customization);
4181 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4182 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4184 device_name_dsc.dsc$a_pointer = device_name;
4185 device_name_dsc.dsc$w_length = sizeof device_name -1;
4186 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4187 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4189 device_name_len = 0;
4191 /* Try to create the window */
4192 status = (*decw_term_port)
4201 if (!$VMS_STATUS_SUCCESS(status)) {
4202 SETERRNO(EVMSERR, status);
4206 device_name[device_name_len] = '\0';
4208 /* Need to set this up to look like a pipe for cleanup */
4210 status = lib$get_vm(&n, &info);
4211 if (!$VMS_STATUS_SUCCESS(status)) {
4212 SETERRNO(ENOMEM, status);
4218 info->completion = 0;
4219 info->closing = FALSE;
4226 info->in_done = TRUE;
4227 info->out_done = TRUE;
4228 info->err_done = TRUE;
4230 /* Assign a channel on this so that it will persist, and not login */
4231 /* We stash this channel in the info structure for reference. */
4232 /* The created xterm self destructs when the last channel is removed */
4233 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4234 /* So leave this assigned. */
4235 device_name_dsc.dsc$w_length = device_name_len;
4236 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4237 if (!$VMS_STATUS_SUCCESS(status)) {
4238 SETERRNO(EVMSERR, status);
4241 info->xchan_valid = 1;
4243 /* Now create a mailbox to be read by the application */
4245 create_mbx(&p_chan, &d_mbx1);
4247 /* write the name of the created terminal to the mailbox */
4248 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4249 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4251 if (!$VMS_STATUS_SUCCESS(status)) {
4252 SETERRNO(EVMSERR, status);
4256 info->fp = PerlIO_open(mbx1, mode);
4258 /* Done with this channel */
4261 /* If any errors, then clean up */
4264 _ckvmssts_noperl(lib$free_vm(&n, &info));
4272 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4275 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4277 static int handler_set_up = FALSE;
4279 unsigned long int sts, flags = CLI$M_NOWAIT;
4280 /* The use of a GLOBAL table (as was done previously) rendered
4281 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4282 * environment. Hence we've switched to LOCAL symbol table.
4284 unsigned int table = LIB$K_CLI_LOCAL_SYM;
4286 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4287 char *in, *out, *err, mbx[512];
4289 char tfilebuf[NAM$C_MAXRSS+1];
4291 char cmd_sym_name[20];
4292 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4293 DSC$K_CLASS_S, symbol};
4294 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4296 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4297 DSC$K_CLASS_S, cmd_sym_name};
4298 struct dsc$descriptor_s *vmscmd;
4299 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4300 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4301 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4303 /* Check here for Xterm create request. This means looking for
4304 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4305 * is possible to create an xterm.
4307 if (*in_mode == 'r') {
4310 #if defined(PERL_IMPLICIT_CONTEXT)
4311 /* Can not fork an xterm with a NULL context */
4312 /* This probably could never happen */
4316 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4317 if (xterm_fd != NULL)
4321 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4323 /* once-per-program initialization...
4324 note that the SETAST calls and the dual test of pipe_ef
4325 makes sure that only the FIRST thread through here does
4326 the initialization...all other threads wait until it's
4329 Yeah, uglier than a pthread call, it's got all the stuff inline
4330 rather than in a separate routine.
4334 _ckvmssts_noperl(sys$setast(0));
4336 unsigned long int pidcode = JPI$_PID;
4337 $DESCRIPTOR(d_delay, RETRY_DELAY);
4338 _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4339 _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4340 _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4342 if (!handler_set_up) {
4343 _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4344 handler_set_up = TRUE;
4346 _ckvmssts_noperl(sys$setast(1));
4349 /* see if we can find a VMSPIPE.COM */
4352 vmspipe = find_vmspipe(aTHX);
4354 strcpy(tfilebuf+1,vmspipe);
4355 } else { /* uh, oh...we're in tempfile hell */
4356 tpipe = vmspipe_tempfile(aTHX);
4357 if (!tpipe) { /* a fish popular in Boston */
4358 if (ckWARN(WARN_PIPE)) {
4359 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4363 fgetname(tpipe,tfilebuf+1,1);
4365 vmspipedsc.dsc$a_pointer = tfilebuf;
4366 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4368 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4371 case RMS$_FNF: case RMS$_DNF:
4372 set_errno(ENOENT); break;
4374 set_errno(ENOTDIR); break;
4376 set_errno(ENODEV); break;
4378 set_errno(EACCES); break;
4380 set_errno(EINVAL); break;
4381 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4382 set_errno(E2BIG); break;
4383 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4384 _ckvmssts_noperl(sts); /* fall through */
4385 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4388 set_vaxc_errno(sts);
4389 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4390 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4396 _ckvmssts_noperl(lib$get_vm(&n, &info));
4398 strcpy(mode,in_mode);
4401 info->completion = 0;
4402 info->closing = FALSE;
4409 info->in_done = TRUE;
4410 info->out_done = TRUE;
4411 info->err_done = TRUE;
4413 info->xchan_valid = 0;
4415 in = PerlMem_malloc(VMS_MAXRSS);
4416 if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4417 out = PerlMem_malloc(VMS_MAXRSS);
4418 if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4419 err = PerlMem_malloc(VMS_MAXRSS);
4420 if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4422 in[0] = out[0] = err[0] = '\0';
4424 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4428 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4433 if (*mode == 'r') { /* piping from subroutine */
4435 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4437 info->out->pipe_done = &info->out_done;
4438 info->out_done = FALSE;
4439 info->out->info = info;
4441 if (!info->useFILE) {
4442 info->fp = PerlIO_open(mbx, mode);
4444 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4445 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4448 if (!info->fp && info->out) {
4449 sys$cancel(info->out->chan_out);
4451 while (!info->out_done) {
4453 _ckvmssts_noperl(sys$setast(0));
4454 done = info->out_done;
4455 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4456 _ckvmssts_noperl(sys$setast(1));
4457 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4460 if (info->out->buf) {
4461 n = info->out->bufsize * sizeof(char);
4462 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4465 _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4467 _ckvmssts_noperl(lib$free_vm(&n, &info));
4472 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4474 info->err->pipe_done = &info->err_done;
4475 info->err_done = FALSE;
4476 info->err->info = info;
4479 } else if (*mode == 'w') { /* piping to subroutine */
4481 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4483 info->out->pipe_done = &info->out_done;
4484 info->out_done = FALSE;
4485 info->out->info = info;
4488 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4490 info->err->pipe_done = &info->err_done;
4491 info->err_done = FALSE;
4492 info->err->info = info;
4495 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4496 if (!info->useFILE) {
4497 info->fp = PerlIO_open(mbx, mode);
4499 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4500 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4504 info->in->pipe_done = &info->in_done;
4505 info->in_done = FALSE;
4506 info->in->info = info;
4510 if (!info->fp && info->in) {
4512 _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4513 0, 0, 0, 0, 0, 0, 0, 0));
4515 while (!info->in_done) {
4517 _ckvmssts_noperl(sys$setast(0));
4518 done = info->in_done;
4519 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4520 _ckvmssts_noperl(sys$setast(1));
4521 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4524 if (info->in->buf) {
4525 n = info->in->bufsize * sizeof(char);
4526 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4529 _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4531 _ckvmssts_noperl(lib$free_vm(&n, &info));
4537 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4538 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4540 info->out->pipe_done = &info->out_done;
4541 info->out_done = FALSE;
4542 info->out->info = info;
4545 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4547 info->err->pipe_done = &info->err_done;
4548 info->err_done = FALSE;
4549 info->err->info = info;
4553 symbol[MAX_DCL_SYMBOL] = '\0';
4555 strncpy(symbol, in, MAX_DCL_SYMBOL);
4556 d_symbol.dsc$w_length = strlen(symbol);
4557 _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4559 strncpy(symbol, err, MAX_DCL_SYMBOL);
4560 d_symbol.dsc$w_length = strlen(symbol);
4561 _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4563 strncpy(symbol, out, MAX_DCL_SYMBOL);
4564 d_symbol.dsc$w_length = strlen(symbol);
4565 _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4567 /* Done with the names for the pipes */
4572 p = vmscmd->dsc$a_pointer;
4573 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4574 if (*p == '$') p++; /* remove leading $ */
4575 while (*p == ' ' || *p == '\t') p++;
4577 for (j = 0; j < 4; j++) {
4578 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4579 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4581 strncpy(symbol, p, MAX_DCL_SYMBOL);
4582 d_symbol.dsc$w_length = strlen(symbol);
4583 _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4585 if (strlen(p) > MAX_DCL_SYMBOL) {
4586 p += MAX_DCL_SYMBOL;
4591 _ckvmssts_noperl(sys$setast(0));
4592 info->next=open_pipes; /* prepend to list */
4594 _ckvmssts_noperl(sys$setast(1));
4595 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4596 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4597 * have SYS$COMMAND if we need it.
4599 _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4600 0, &info->pid, &info->completion,
4601 0, popen_completion_ast,info,0,0,0));
4603 /* if we were using a tempfile, close it now */
4605 if (tpipe) fclose(tpipe);
4607 /* once the subprocess is spawned, it has copied the symbols and
4608 we can get rid of ours */
4610 for (j = 0; j < 4; j++) {
4611 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4612 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4613 _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4615 _ckvmssts_noperl(lib$delete_symbol(&d_sym_in, &table));
4616 _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4617 _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4618 vms_execfree(vmscmd);
4620 #ifdef PERL_IMPLICIT_CONTEXT
4623 PL_forkprocess = info->pid;
4630 _ckvmssts_noperl(sys$setast(0));
4632 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4633 _ckvmssts_noperl(sys$setast(1));
4634 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4636 *psts = info->completion;
4637 /* Caller thinks it is open and tries to close it. */
4638 /* This causes some problems, as it changes the error status */
4639 /* my_pclose(info->fp); */
4641 /* If we did not have a file pointer open, then we have to */
4642 /* clean up here or eventually we will run out of something */
4644 if (info->fp == NULL) {
4645 my_pclose_pinfo(aTHX_ info);
4653 } /* end of safe_popen */
4656 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4658 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4662 TAINT_PROPER("popen");
4663 PERL_FLUSHALL_FOR_CHILD;
4664 return safe_popen(aTHX_ cmd,mode,&sts);
4670 /* Routine to close and cleanup a pipe info structure */
4672 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4674 unsigned long int retsts;
4679 /* If we were writing to a subprocess, insure that someone reading from
4680 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4681 * produce an EOF record in the mailbox.
4683 * well, at least sometimes it *does*, so we have to watch out for
4684 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4688 #if defined(USE_ITHREADS)
4692 && PL_perlio_fd_refcnt
4695 PerlIO_flush(info->fp);
4697 fflush((FILE *)info->fp);
4700 _ckvmssts(sys$setast(0));
4701 info->closing = TRUE;
4702 done = info->done && info->in_done && info->out_done && info->err_done;
4703 /* hanging on write to Perl's input? cancel it */
4704 if (info->mode == 'r' && info->out && !info->out_done) {
4705 if (info->out->chan_out) {
4706 _ckvmssts(sys$cancel(info->out->chan_out));
4707 if (!info->out->chan_in) { /* EOF generation, need AST */
4708 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4712 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4713 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4715 _ckvmssts(sys$setast(1));
4718 #if defined(USE_ITHREADS)
4722 && PL_perlio_fd_refcnt
4725 PerlIO_close(info->fp);
4727 fclose((FILE *)info->fp);
4730 we have to wait until subprocess completes, but ALSO wait until all
4731 the i/o completes...otherwise we'll be freeing the "info" structure
4732 that the i/o ASTs could still be using...
4736 _ckvmssts(sys$setast(0));
4737 done = info->done && info->in_done && info->out_done && info->err_done;
4738 if (!done) _ckvmssts(sys$clref(pipe_ef));
4739 _ckvmssts(sys$setast(1));
4740 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4742 retsts = info->completion;
4744 /* remove from list of open pipes */
4745 _ckvmssts(sys$setast(0));
4747 for (next = open_pipes; next != NULL; last = next, next = next->next) {
4753 last->next = info->next;
4755 open_pipes = info->next;
4756 _ckvmssts(sys$setast(1));
4758 /* free buffers and structures */
4761 if (info->in->buf) {
4762 n = info->in->bufsize * sizeof(char);
4763 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4766 _ckvmssts(lib$free_vm(&n, &info->in));
4769 if (info->out->buf) {
4770 n = info->out->bufsize * sizeof(char);
4771 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4774 _ckvmssts(lib$free_vm(&n, &info->out));
4777 if (info->err->buf) {
4778 n = info->err->bufsize * sizeof(char);
4779 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4782 _ckvmssts(lib$free_vm(&n, &info->err));
4785 _ckvmssts(lib$free_vm(&n, &info));
4791 /*{{{ I32 my_pclose(PerlIO *fp)*/
4792 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4794 pInfo info, last = NULL;
4797 /* Fixme - need ast and mutex protection here */
4798 for (info = open_pipes; info != NULL; last = info, info = info->next)
4799 if (info->fp == fp) break;
4801 if (info == NULL) { /* no such pipe open */
4802 set_errno(ECHILD); /* quoth POSIX */
4803 set_vaxc_errno(SS$_NONEXPR);
4807 ret_status = my_pclose_pinfo(aTHX_ info);
4811 } /* end of my_pclose() */
4813 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4814 /* Roll our own prototype because we want this regardless of whether
4815 * _VMS_WAIT is defined.
4817 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4819 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4820 created with popen(); otherwise partially emulate waitpid() unless
4821 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4822 Also check processes not considered by the CRTL waitpid().
4824 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4826 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4833 if (statusp) *statusp = 0;
4835 for (info = open_pipes; info != NULL; info = info->next)
4836 if (info->pid == pid) break;
4838 if (info != NULL) { /* we know about this child */
4839 while (!info->done) {
4840 _ckvmssts(sys$setast(0));
4842 if (!done) _ckvmssts(sys$clref(pipe_ef));
4843 _ckvmssts(sys$setast(1));
4844 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4847 if (statusp) *statusp = info->completion;
4851 /* child that already terminated? */
4853 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4854 if (closed_list[j].pid == pid) {
4855 if (statusp) *statusp = closed_list[j].completion;
4860 /* fall through if this child is not one of our own pipe children */
4862 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4864 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4865 * in 7.2 did we get a version that fills in the VMS completion
4866 * status as Perl has always tried to do.
4869 sts = __vms_waitpid( pid, statusp, flags );
4871 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4874 /* If the real waitpid tells us the child does not exist, we
4875 * fall through here to implement waiting for a child that
4876 * was created by some means other than exec() (say, spawned
4877 * from DCL) or to wait for a process that is not a subprocess
4878 * of the current process.
4881 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4884 $DESCRIPTOR(intdsc,"0 00:00:01");
4885 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4886 unsigned long int pidcode = JPI$_PID, mypid;
4887 unsigned long int interval[2];
4888 unsigned int jpi_iosb[2];
4889 struct itmlst_3 jpilist[2] = {
4890 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4895 /* Sorry folks, we don't presently implement rooting around for
4896 the first child we can find, and we definitely don't want to
4897 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4903 /* Get the owner of the child so I can warn if it's not mine. If the
4904 * process doesn't exist or I don't have the privs to look at it,
4905 * I can go home early.
4907 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4908 if (sts & 1) sts = jpi_iosb[0];
4920 set_vaxc_errno(sts);
4924 if (ckWARN(WARN_EXEC)) {
4925 /* remind folks they are asking for non-standard waitpid behavior */
4926 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4927 if (ownerpid != mypid)
4928 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4929 "waitpid: process %x is not a child of process %x",
4933 /* simply check on it once a second until it's not there anymore. */
4935 _ckvmssts(sys$bintim(&intdsc,interval));
4936 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4937 _ckvmssts(sys$schdwk(0,0,interval,0));
4938 _ckvmssts(sys$hiber());
4940 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4945 } /* end of waitpid() */
4950 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4952 my_gconvert(double val, int ndig, int trail, char *buf)
4954 static char __gcvtbuf[DBL_DIG+1];
4957 loc = buf ? buf : __gcvtbuf;
4959 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4961 sprintf(loc,"%.*g",ndig,val);
4967 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4968 return gcvt(val,ndig,loc);
4971 loc[0] = '0'; loc[1] = '\0';
4978 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4979 static int rms_free_search_context(struct FAB * fab)
4983 nam = fab->fab$l_nam;
4984 nam->nam$b_nop |= NAM$M_SYNCHK;
4985 nam->nam$l_rlf = NULL;
4987 return sys$parse(fab, NULL, NULL);
4990 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4991 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4992 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4993 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4994 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4995 #define rms_nam_esll(nam) nam.nam$b_esl
4996 #define rms_nam_esl(nam) nam.nam$b_esl
4997 #define rms_nam_name(nam) nam.nam$l_name
4998 #define rms_nam_namel(nam) nam.nam$l_name
4999 #define rms_nam_type(nam) nam.nam$l_type
5000 #define rms_nam_typel(nam) nam.nam$l_type
5001 #define rms_nam_ver(nam) nam.nam$l_ver
5002 #define rms_nam_verl(nam) nam.nam$l_ver
5003 #define rms_nam_rsll(nam) nam.nam$b_rsl
5004 #define rms_nam_rsl(nam) nam.nam$b_rsl
5005 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
5006 #define rms_set_fna(fab, nam, name, size) \
5007 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
5008 #define rms_get_fna(fab, nam) fab.fab$l_fna
5009 #define rms_set_dna(fab, nam, name, size) \
5010 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
5011 #define rms_nam_dns(fab, nam) fab.fab$b_dns
5012 #define rms_set_esa(nam, name, size) \
5013 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
5014 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5015 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
5016 #define rms_set_rsa(nam, name, size) \
5017 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
5018 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5019 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
5020 #define rms_nam_name_type_l_size(nam) \
5021 (nam.nam$b_name + nam.nam$b_type)
5023 static int rms_free_search_context(struct FAB * fab)
5027 nam = fab->fab$l_naml;
5028 nam->naml$b_nop |= NAM$M_SYNCHK;
5029 nam->naml$l_rlf = NULL;
5030 nam->naml$l_long_defname_size = 0;
5033 return sys$parse(fab, NULL, NULL);
5036 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
5037 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
5038 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
5039 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
5040 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
5041 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
5042 #define rms_nam_esl(nam) nam.naml$b_esl
5043 #define rms_nam_name(nam) nam.naml$l_name
5044 #define rms_nam_namel(nam) nam.naml$l_long_name
5045 #define rms_nam_type(nam) nam.naml$l_type
5046 #define rms_nam_typel(nam) nam.naml$l_long_type
5047 #define rms_nam_ver(nam) nam.naml$l_ver
5048 #define rms_nam_verl(nam) nam.naml$l_long_ver
5049 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
5050 #define rms_nam_rsl(nam) nam.naml$b_rsl
5051 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
5052 #define rms_set_fna(fab, nam, name, size) \
5053 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
5054 nam.naml$l_long_filename_size = size; \
5055 nam.naml$l_long_filename = name;}
5056 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
5057 #define rms_set_dna(fab, nam, name, size) \
5058 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
5059 nam.naml$l_long_defname_size = size; \
5060 nam.naml$l_long_defname = name; }
5061 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
5062 #define rms_set_esa(nam, name, size) \
5063 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
5064 nam.naml$l_long_expand_alloc = size; \
5065 nam.naml$l_long_expand = name; }
5066 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5067 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
5068 nam.naml$l_long_expand = l_name; \
5069 nam.naml$l_long_expand_alloc = l_size; }
5070 #define rms_set_rsa(nam, name, size) \
5071 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
5072 nam.naml$l_long_result = name; \
5073 nam.naml$l_long_result_alloc = size; }
5074 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5075 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
5076 nam.naml$l_long_result = l_name; \
5077 nam.naml$l_long_result_alloc = l_size; }
5078 #define rms_nam_name_type_l_size(nam) \
5079 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
5084 * The CRTL for 8.3 and later can create symbolic links in any mode,
5085 * however in 8.3 the unlink/remove/delete routines will only properly handle
5086 * them if one of the PCP modes is active.
5088 static int rms_erase(const char * vmsname)
5091 struct FAB myfab = cc$rms_fab;
5092 rms_setup_nam(mynam);
5094 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
5095 rms_bind_fab_nam(myfab, mynam);
5097 #ifdef NAML$M_OPEN_SPECIAL
5098 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5101 status = sys$erase(&myfab, 0, 0);
5108 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5109 const struct dsc$descriptor_s * vms_dst_dsc,
5110 unsigned long flags)
5112 /* VMS and UNIX handle file permissions differently and the
5113 * the same ACL trick may be needed for renaming files,
5114 * especially if they are directories.
5117 /* todo: get kill_file and rename to share common code */
5118 /* I can not find online documentation for $change_acl
5119 * it appears to be replaced by $set_security some time ago */
5121 const unsigned int access_mode = 0;
5122 $DESCRIPTOR(obj_file_dsc,"FILE");
5125 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5126 int aclsts, fndsts, rnsts = -1;
5127 unsigned int ctx = 0;
5128 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5129 struct dsc$descriptor_s * clean_dsc;
5132 unsigned char myace$b_length;
5133 unsigned char myace$b_type;
5134 unsigned short int myace$w_flags;
5135 unsigned long int myace$l_access;
5136 unsigned long int myace$l_ident;
5137 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5138 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5140 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5143 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5144 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5146 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5147 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5151 /* Expand the input spec using RMS, since we do not want to put
5152 * ACLs on the target of a symbolic link */
5153 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5154 if (vmsname == NULL)
5157 rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5159 PERL_RMSEXPAND_M_SYMLINK);
5161 PerlMem_free(vmsname);
5165 /* So we get our own UIC to use as a rights identifier,
5166 * and the insert an ACE at the head of the ACL which allows us
5167 * to delete the file.
5169 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5171 fildsc.dsc$w_length = strlen(vmsname);
5172 fildsc.dsc$a_pointer = vmsname;
5174 newace.myace$l_ident = oldace.myace$l_ident;
5177 /* Grab any existing ACEs with this identifier in case we fail */
5178 clean_dsc = &fildsc;
5179 aclsts = fndsts = sys$get_security(&obj_file_dsc,
5187 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
5188 /* Add the new ACE . . . */
5190 /* if the sys$get_security succeeded, then ctx is valid, and the
5191 * object/file descriptors will be ignored. But otherwise they
5194 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5195 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5196 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5198 set_vaxc_errno(aclsts);
5199 PerlMem_free(vmsname);
5203 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5206 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5208 if ($VMS_STATUS_SUCCESS(rnsts)) {
5209 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5212 /* Put things back the way they were. */
5214 aclsts = sys$get_security(&obj_file_dsc,
5222 if ($VMS_STATUS_SUCCESS(aclsts)) {
5226 if (!$VMS_STATUS_SUCCESS(fndsts))
5227 sec_flags = OSS$M_RELCTX;
5229 /* Get rid of the new ACE */
5230 aclsts = sys$set_security(NULL, NULL, NULL,
5231 sec_flags, dellst, &ctx, &access_mode);
5233 /* If there was an old ACE, put it back */
5234 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5235 addlst[0].bufadr = &oldace;
5236 aclsts = sys$set_security(NULL, NULL, NULL,
5237 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5238 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5240 set_vaxc_errno(aclsts);
5246 /* Try to clear the lock on the ACL list */
5247 aclsts2 = sys$set_security(NULL, NULL, NULL,
5248 OSS$M_RELCTX, NULL, &ctx, &access_mode);
5250 /* Rename errors are most important */
5251 if (!$VMS_STATUS_SUCCESS(rnsts))
5254 set_vaxc_errno(aclsts);
5259 if (aclsts != SS$_ACLEMPTY)
5266 PerlMem_free(vmsname);
5271 /*{{{int rename(const char *, const char * */
5272 /* Not exactly what X/Open says to do, but doing it absolutely right
5273 * and efficiently would require a lot more work. This should be close
5274 * enough to pass all but the most strict X/Open compliance test.
5277 Perl_rename(pTHX_ const char *src, const char * dst)
5286 /* Validate the source file */
5287 src_sts = flex_lstat(src, &src_st);
5290 /* No source file or other problem */
5293 if (src_st.st_devnam[0] == 0) {
5294 /* This may be possible so fail if it is seen. */
5299 dst_sts = flex_lstat(dst, &dst_st);
5302 if (dst_st.st_dev != src_st.st_dev) {
5303 /* Must be on the same device */
5308 /* VMS_INO_T_COMPARE is true if the inodes are different
5309 * to match the output of memcmp
5312 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5313 /* That was easy, the files are the same! */
5317 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5318 /* If source is a directory, so must be dest */
5326 if ((dst_sts == 0) &&
5327 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5329 /* We have issues here if vms_unlink_all_versions is set
5330 * If the destination exists, and is not a directory, then
5331 * we must delete in advance.
5333 * If the src is a directory, then we must always pre-delete
5336 * If we successfully delete the dst in advance, and the rename fails
5337 * X/Open requires that errno be EIO.
5341 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5343 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5344 S_ISDIR(dst_st.st_mode));
5346 /* Need to delete all versions ? */
5347 if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5350 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5351 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5356 /* Make sure that we do not loop forever */
5368 /* We killed the destination, so only errno now is EIO */
5373 /* Originally the idea was to call the CRTL rename() and only
5374 * try the lib$rename_file if it failed.
5375 * It turns out that there are too many variants in what the
5376 * the CRTL rename might do, so only use lib$rename_file
5381 /* Is the source and dest both in VMS format */
5382 /* if the source is a directory, then need to fileify */
5383 /* and dest must be a directory or non-existant. */
5388 unsigned long flags;
5389 struct dsc$descriptor_s old_file_dsc;
5390 struct dsc$descriptor_s new_file_dsc;
5392 /* We need to modify the src and dst depending
5393 * on if one or more of them are directories.
5396 vms_dst = PerlMem_malloc(VMS_MAXRSS);
5397 if (vms_dst == NULL)
5398 _ckvmssts_noperl(SS$_INSFMEM);
5400 if (S_ISDIR(src_st.st_mode)) {
5402 char * vms_dir_file;
5404 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5405 if (vms_dir_file == NULL)
5406 _ckvmssts_noperl(SS$_INSFMEM);
5408 /* If the dest is a directory, we must remove it
5411 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5413 PerlMem_free(vms_dst);
5421 /* The dest must be a VMS file specification */
5422 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5423 if (ret_str == NULL) {
5424 PerlMem_free(vms_dst);
5429 /* The source must be a file specification */
5430 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5431 if (vms_dir_file == NULL)
5432 _ckvmssts_noperl(SS$_INSFMEM);
5434 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5435 if (ret_str == NULL) {
5436 PerlMem_free(vms_dst);
5437 PerlMem_free(vms_dir_file);
5441 PerlMem_free(vms_dst);
5442 vms_dst = vms_dir_file;
5445 /* File to file or file to new dir */
5447 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5448 /* VMS pathify a dir target */
5449 ret_str = int_tovmspath(dst, vms_dst, NULL);
5450 if (ret_str == NULL) {
5451 PerlMem_free(vms_dst);
5456 char * v_spec, * r_spec, * d_spec, * n_spec;
5457 char * e_spec, * vs_spec;
5458 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5460 /* fileify a target VMS file specification */
5461 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5462 if (ret_str == NULL) {
5463 PerlMem_free(vms_dst);
5468 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5469 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5470 &e_len, &vs_spec, &vs_len);
5473 /* Get rid of the version */
5477 /* Need to specify a '.' so that the extension */
5478 /* is not inherited */
5479 strcat(vms_dst,".");
5485 old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5486 old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5487 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5488 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5490 new_file_dsc.dsc$a_pointer = vms_dst;
5491 new_file_dsc.dsc$w_length = strlen(vms_dst);
5492 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5493 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5496 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5497 flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5500 sts = lib$rename_file(&old_file_dsc,
5504 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5505 if (!$VMS_STATUS_SUCCESS(sts)) {
5507 /* We could have failed because VMS style permissions do not
5508 * permit renames that UNIX will allow. Just like the hack
5511 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5514 PerlMem_free(vms_dst);
5515 if (!$VMS_STATUS_SUCCESS(sts)) {
5522 if (vms_unlink_all_versions) {
5523 /* Now get rid of any previous versions of the source file that
5529 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5530 S_ISDIR(src_st.st_mode));
5531 while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5532 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5533 S_ISDIR(src_st.st_mode));
5538 /* Make sure that we do not loop forever */
5547 /* We deleted the destination, so must force the error to be EIO */
5548 if ((retval != 0) && (pre_delete != 0))
5556 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5557 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5558 * to expand file specification. Allows for a single default file
5559 * specification and a simple mask of options. If outbuf is non-NULL,
5560 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5561 * the resultant file specification is placed. If outbuf is NULL, the
5562 * resultant file specification is placed into a static buffer.
5563 * The third argument, if non-NULL, is taken to be a default file
5564 * specification string. The fourth argument is unused at present.
5565 * rmesexpand() returns the address of the resultant string if
5566 * successful, and NULL on error.
5568 * New functionality for previously unused opts value:
5569 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5570 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5571 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5572 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5574 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5578 (const char *filespec,
5580 const char *defspec,
5586 const char * in_spec;
5588 const char * def_spec;
5589 char * vmsfspec, *vmsdefspec;
5593 struct FAB myfab = cc$rms_fab;
5594 rms_setup_nam(mynam);
5596 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5599 /* temp hack until UTF8 is actually implemented */
5600 if (fs_utf8 != NULL)
5603 if (!filespec || !*filespec) {
5604 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5614 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5615 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5616 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5618 /* If this is a UNIX file spec, convert it to VMS */
5619 sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5620 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5621 &e_len, &vs_spec, &vs_len);
5626 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5627 if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5628 ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5629 if (ret_spec == NULL) {
5630 PerlMem_free(vmsfspec);
5633 in_spec = (const char *)vmsfspec;
5635 /* Unless we are forcing to VMS format, a UNIX input means
5636 * UNIX output, and that requires long names to be used
5638 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5639 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5640 opts |= PERL_RMSEXPAND_M_LONG;
5650 rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5651 rms_bind_fab_nam(myfab, mynam);
5653 /* Process the default file specification if present */
5655 if (defspec && *defspec) {
5657 t_isunix = is_unix_filespec(defspec);
5659 vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5660 if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5661 ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5663 if (ret_spec == NULL) {
5664 /* Clean up and bail */
5665 PerlMem_free(vmsdefspec);
5666 if (vmsfspec != NULL)
5667 PerlMem_free(vmsfspec);
5670 def_spec = (const char *)vmsdefspec;
5672 rms_set_dna(myfab, mynam,
5673 (char *)def_spec, strlen(def_spec)); /* cast ok */
5676 /* Now we need the expansion buffers */
5677 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5678 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5679 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5680 esal = PerlMem_malloc(VMS_MAXRSS);
5681 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5683 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5685 /* If a NAML block is used RMS always writes to the long and short
5686 * addresses unless you suppress the short name.
5688 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5689 outbufl = PerlMem_malloc(VMS_MAXRSS);
5690 if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5692 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5694 #ifdef NAM$M_NO_SHORT_UPCASE
5695 if (decc_efs_case_preserve)
5696 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5699 /* We may not want to follow symbolic links */
5700 #ifdef NAML$M_OPEN_SPECIAL
5701 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5702 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5705 /* First attempt to parse as an existing file */
5706 retsts = sys$parse(&myfab,0,0);
5707 if (!(retsts & STS$K_SUCCESS)) {
5709 /* Could not find the file, try as syntax only if error is not fatal */
5710 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5711 if (retsts == RMS$_DNF ||
5712 retsts == RMS$_DIR ||
5713 retsts == RMS$_DEV ||
5714 retsts == RMS$_PRV) {
5715 retsts = sys$parse(&myfab,0,0);
5716 if (retsts & STS$K_SUCCESS) goto int_expanded;
5719 /* Still could not parse the file specification */
5720 /*----------------------------------------------*/
5721 sts = rms_free_search_context(&myfab); /* Free search context */
5722 if (vmsdefspec != NULL)
5723 PerlMem_free(vmsdefspec);
5724 if (vmsfspec != NULL)
5725 PerlMem_free(vmsfspec);
5726 if (outbufl != NULL)
5727 PerlMem_free(outbufl);
5731 set_vaxc_errno(retsts);
5732 if (retsts == RMS$_PRV) set_errno(EACCES);
5733 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5734 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5735 else set_errno(EVMSERR);
5738 retsts = sys$search(&myfab,0,0);
5739 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5740 sts = rms_free_search_context(&myfab); /* Free search context */
5741 if (vmsdefspec != NULL)
5742 PerlMem_free(vmsdefspec);
5743 if (vmsfspec != NULL)
5744 PerlMem_free(vmsfspec);
5745 if (outbufl != NULL)
5746 PerlMem_free(outbufl);
5750 set_vaxc_errno(retsts);
5751 if (retsts == RMS$_PRV) set_errno(EACCES);
5752 else set_errno(EVMSERR);
5756 /* If the input filespec contained any lowercase characters,
5757 * downcase the result for compatibility with Unix-minded code. */
5759 if (!decc_efs_case_preserve) {
5761 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5762 if (islower(*tbuf)) { haslower = 1; break; }
5765 /* Is a long or a short name expected */
5766 /*------------------------------------*/
5768 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5769 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5770 if (rms_nam_rsll(mynam)) {
5772 speclen = rms_nam_rsll(mynam);
5775 spec_buf = esal; /* Not esa */
5776 speclen = rms_nam_esll(mynam);
5781 if (rms_nam_rsl(mynam)) {
5783 speclen = rms_nam_rsl(mynam);
5786 spec_buf = esa; /* Not esal */
5787 speclen = rms_nam_esl(mynam);
5789 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5792 spec_buf[speclen] = '\0';
5794 /* Trim off null fields added by $PARSE
5795 * If type > 1 char, must have been specified in original or default spec
5796 * (not true for version; $SEARCH may have added version of existing file).
5798 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5799 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5800 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5801 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5804 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5805 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5807 if (trimver || trimtype) {
5808 if (defspec && *defspec) {
5809 char *defesal = NULL;
5810 char *defesa = NULL;
5811 defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5812 if (defesa != NULL) {
5813 struct FAB deffab = cc$rms_fab;
5814 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5815 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5816 if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5818 rms_setup_nam(defnam);
5820 rms_bind_fab_nam(deffab, defnam);
5824 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5826 /* RMS needs the esa/esal as a work area if wildcards are involved */
5827 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5829 rms_clear_nam_nop(defnam);
5830 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5831 #ifdef NAM$M_NO_SHORT_UPCASE
5832 if (decc_efs_case_preserve)
5833 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5835 #ifdef NAML$M_OPEN_SPECIAL
5836 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5837 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5839 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5841 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5844 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5847 if (defesal != NULL)
5848 PerlMem_free(defesal);
5849 PerlMem_free(defesa);
5851 _ckvmssts_noperl(SS$_INSFMEM);
5855 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5856 if (*(rms_nam_verl(mynam)) != '\"')
5857 speclen = rms_nam_verl(mynam) - spec_buf;
5860 if (*(rms_nam_ver(mynam)) != '\"')
5861 speclen = rms_nam_ver(mynam) - spec_buf;
5865 /* If we didn't already trim version, copy down */
5866 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5867 if (speclen > rms_nam_verl(mynam) - spec_buf)
5869 (rms_nam_typel(mynam),
5870 rms_nam_verl(mynam),
5871 speclen - (rms_nam_verl(mynam) - spec_buf));
5872 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5875 if (speclen > rms_nam_ver(mynam) - spec_buf)
5877 (rms_nam_type(mynam),
5879 speclen - (rms_nam_ver(mynam) - spec_buf));
5880 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5885 /* Done with these copies of the input files */
5886 /*-------------------------------------------*/
5887 if (vmsfspec != NULL)
5888 PerlMem_free(vmsfspec);
5889 if (vmsdefspec != NULL)
5890 PerlMem_free(vmsdefspec);
5892 /* If we just had a directory spec on input, $PARSE "helpfully"
5893 * adds an empty name and type for us */
5894 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5895 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5896 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5897 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5898 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5899 speclen = rms_nam_namel(mynam) - spec_buf;
5904 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5905 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5906 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5907 speclen = rms_nam_name(mynam) - spec_buf;
5910 /* Posix format specifications must have matching quotes */
5911 if (speclen < (VMS_MAXRSS - 1)) {
5912 if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5913 if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5914 spec_buf[speclen] = '\"';
5919 spec_buf[speclen] = '\0';
5920 if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5922 /* Have we been working with an expanded, but not resultant, spec? */
5923 /* Also, convert back to Unix syntax if necessary. */
5927 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5928 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5929 rsl = rms_nam_rsll(mynam);
5933 rsl = rms_nam_rsl(mynam);
5936 /* rsl is not present, it means that spec_buf is either */
5937 /* esa or esal, and needs to be copied to outbuf */
5938 /* convert to Unix if desired */
5940 ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5942 /* VMS file specs are not in UTF-8 */
5943 if (fs_utf8 != NULL)
5945 strcpy(outbuf, spec_buf);
5950 /* Now spec_buf is either outbuf or outbufl */
5951 /* We need the result into outbuf */
5953 /* If we need this in UNIX, then we need another buffer */
5954 /* to keep things in order */
5956 char * new_src = NULL;
5957 if (spec_buf == outbuf) {
5958 new_src = PerlMem_malloc(VMS_MAXRSS);
5959 strcpy(new_src, spec_buf);
5963 ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5965 PerlMem_free(new_src);
5968 /* VMS file specs are not in UTF-8 */
5969 if (fs_utf8 != NULL)
5972 /* Copy the buffer if needed */
5973 if (outbuf != spec_buf)
5974 strcpy(outbuf, spec_buf);
5980 /* Need to clean up the search context */
5981 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5982 sts = rms_free_search_context(&myfab); /* Free search context */
5984 /* Clean up the extra buffers */
5988 if (outbufl != NULL)
5989 PerlMem_free(outbufl);
5991 /* Return the result */
5995 /* Common simple case - Expand an already VMS spec */
5997 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5998 opts |= PERL_RMSEXPAND_M_VMS_IN;
5999 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
6002 /* Common simple case - Expand to a VMS spec */
6004 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
6005 opts |= PERL_RMSEXPAND_M_VMS;
6006 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
6010 /* Entry point used by perl routines */
6013 (pTHX_ const char *filespec,
6016 const char *defspec,
6021 static char __rmsexpand_retbuf[VMS_MAXRSS];
6022 char * expanded, *ret_spec, *ret_buf;
6026 if (ret_buf == NULL) {
6028 Newx(expanded, VMS_MAXRSS, char);
6029 if (expanded == NULL)
6030 _ckvmssts(SS$_INSFMEM);
6033 ret_buf = __rmsexpand_retbuf;
6038 ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
6039 opts, fs_utf8, dfs_utf8);
6041 if (ret_spec == NULL) {
6042 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6050 /* External entry points */
6051 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6052 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
6053 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6054 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
6055 char *Perl_rmsexpand_utf8
6056 (pTHX_ const char *spec, char *buf, const char *def,
6057 unsigned opt, int * fs_utf8, int * dfs_utf8)
6058 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
6059 char *Perl_rmsexpand_utf8_ts
6060 (pTHX_ const char *spec, char *buf, const char *def,
6061 unsigned opt, int * fs_utf8, int * dfs_utf8)
6062 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
6066 ** The following routines are provided to make life easier when
6067 ** converting among VMS-style and Unix-style directory specifications.
6068 ** All will take input specifications in either VMS or Unix syntax. On
6069 ** failure, all return NULL. If successful, the routines listed below
6070 ** return a pointer to a buffer containing the appropriately
6071 ** reformatted spec (and, therefore, subsequent calls to that routine
6072 ** will clobber the result), while the routines of the same names with
6073 ** a _ts suffix appended will return a pointer to a mallocd string
6074 ** containing the appropriately reformatted spec.
6075 ** In all cases, only explicit syntax is altered; no check is made that
6076 ** the resulting string is valid or that the directory in question
6079 ** fileify_dirspec() - convert a directory spec into the name of the
6080 ** directory file (i.e. what you can stat() to see if it's a dir).
6081 ** The style (VMS or Unix) of the result is the same as the style
6082 ** of the parameter passed in.
6083 ** pathify_dirspec() - convert a directory spec into a path (i.e.
6084 ** what you prepend to a filename to indicate what directory it's in).
6085 ** The style (VMS or Unix) of the result is the same as the style
6086 ** of the parameter passed in.
6087 ** tounixpath() - convert a directory spec into a Unix-style path.
6088 ** tovmspath() - convert a directory spec into a VMS-style path.
6089 ** tounixspec() - convert any file spec into a Unix-style file spec.
6090 ** tovmsspec() - convert any file spec into a VMS-style spec.
6091 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
6093 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
6094 ** Permission is given to distribute this code as part of the Perl
6095 ** standard distribution under the terms of the GNU General Public
6096 ** License or the Perl Artistic License. Copies of each may be
6097 ** found in the Perl standard distribution.
6100 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6102 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
6104 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
6105 char *cp1, *cp2, *lastdir;
6106 char *trndir, *vmsdir;
6107 unsigned short int trnlnm_iter_count;
6111 if (utf8_fl != NULL)
6114 if (!dir || !*dir) {
6115 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6117 dirlen = strlen(dir);
6118 while (dirlen && dir[dirlen-1] == '/') --dirlen;
6119 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6120 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6127 if (dirlen > (VMS_MAXRSS - 1)) {
6128 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6131 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6132 if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6133 if (!strpbrk(dir+1,"/]>:") &&
6134 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6135 strcpy(trndir,*dir == '/' ? dir + 1: dir);
6136 trnlnm_iter_count = 0;
6137 while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6138 trnlnm_iter_count++;
6139 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6141 dirlen = strlen(trndir);
6144 strncpy(trndir,dir,dirlen);
6145 trndir[dirlen] = '\0';
6148 /* At this point we are done with *dir and use *trndir which is a
6149 * copy that can be modified. *dir must not be modified.
6152 /* If we were handed a rooted logical name or spec, treat it like a
6153 * simple directory, so that
6154 * $ Define myroot dev:[dir.]
6155 * ... do_fileify_dirspec("myroot",buf,1) ...
6156 * does something useful.
6158 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6159 trndir[--dirlen] = '\0';
6160 trndir[dirlen-1] = ']';
6162 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6163 trndir[--dirlen] = '\0';
6164 trndir[dirlen-1] = '>';
6167 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6168 /* If we've got an explicit filename, we can just shuffle the string. */
6169 if (*(cp1+1)) hasfilename = 1;
6170 /* Similarly, we can just back up a level if we've got multiple levels
6171 of explicit directories in a VMS spec which ends with directories. */
6173 for (cp2 = cp1; cp2 > trndir; cp2--) {
6175 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6176 /* fix-me, can not scan EFS file specs backward like this */
6177 *cp2 = *cp1; *cp1 = '\0';
6182 if (*cp2 == '[' || *cp2 == '<') break;
6187 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6188 if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6189 cp1 = strpbrk(trndir,"]:>");
6190 if (hasfilename || !cp1) { /* filename present or not VMS */
6192 if (decc_efs_charset && !cp1) {
6194 /* EFS handling for UNIX mode */
6196 /* Just remove the trailing '/' and we should be done */
6198 trndir_len = strlen(trndir);
6200 if (trndir_len > 1) {
6202 if (trndir[trndir_len] == '/') {
6203 trndir[trndir_len] = '\0';
6206 strcpy(buf, trndir);
6207 PerlMem_free(trndir);
6208 PerlMem_free(vmsdir);
6212 /* For non-EFS mode, this is left for backwards compatibility */
6213 /* For EFS mode, this is only done for VMS format filespecs as */
6214 /* Perl programs generally have problems when a UNIX format spec */
6215 /* returns a VMS format spec */
6216 if (trndir[0] == '.') {
6217 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6218 PerlMem_free(trndir);
6219 PerlMem_free(vmsdir);
6220 return int_fileify_dirspec("[]", buf, NULL);
6222 else if (trndir[1] == '.' &&
6223 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6224 PerlMem_free(trndir);
6225 PerlMem_free(vmsdir);
6226 return int_fileify_dirspec("[-]", buf, NULL);
6229 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
6230 dirlen -= 1; /* to last element */
6231 lastdir = strrchr(trndir,'/');
6233 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6234 /* If we have "/." or "/..", VMSify it and let the VMS code
6235 * below expand it, rather than repeating the code to handle
6236 * relative components of a filespec here */
6238 if (*(cp1+2) == '.') cp1++;
6239 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6241 if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6242 PerlMem_free(trndir);
6243 PerlMem_free(vmsdir);
6246 if (strchr(vmsdir,'/') != NULL) {
6247 /* If int_tovmsspec() returned it, it must have VMS syntax
6248 * delimiters in it, so it's a mixed VMS/Unix spec. We take
6249 * the time to check this here only so we avoid a recursion
6250 * loop; otherwise, gigo.
6252 PerlMem_free(trndir);
6253 PerlMem_free(vmsdir);
6254 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
6257 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6258 PerlMem_free(trndir);
6259 PerlMem_free(vmsdir);
6262 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6263 PerlMem_free(trndir);
6264 PerlMem_free(vmsdir);
6268 } while ((cp1 = strstr(cp1,"/.")) != NULL);
6269 lastdir = strrchr(trndir,'/');
6271 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6273 /* Ditto for specs that end in an MFD -- let the VMS code
6274 * figure out whether it's a real device or a rooted logical. */
6276 /* This should not happen any more. Allowing the fake /000000
6277 * in a UNIX pathname causes all sorts of problems when trying
6278 * to run in UNIX emulation. So the VMS to UNIX conversions
6279 * now remove the fake /000000 directories.
6282 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6283 if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6284 PerlMem_free(trndir);
6285 PerlMem_free(vmsdir);
6288 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6289 PerlMem_free(trndir);
6290 PerlMem_free(vmsdir);
6293 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6294 PerlMem_free(trndir);
6295 PerlMem_free(vmsdir);
6300 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6301 !(lastdir = cp1 = strrchr(trndir,']')) &&
6302 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6304 cp2 = strrchr(cp1,'.');
6306 int e_len, vs_len = 0;
6309 cp3 = strchr(cp2,';');
6310 e_len = strlen(cp2);
6312 vs_len = strlen(cp3);
6313 e_len = e_len - vs_len;
6315 is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6317 if (!decc_efs_charset) {
6318 /* If this is not EFS, then not a directory */
6319 PerlMem_free(trndir);
6320 PerlMem_free(vmsdir);
6322 set_vaxc_errno(RMS$_DIR);
6326 /* Ok, here we have an issue, technically if a .dir shows */
6327 /* from inside a directory, then we should treat it as */
6328 /* xxx^.dir.dir. But we do not have that context at this */
6329 /* point unless this is totally restructured, so we remove */
6330 /* The .dir for now, and fix this better later */
6331 dirlen = cp2 - trndir;
6337 retlen = dirlen + 6;
6338 memcpy(buf, trndir, dirlen);
6341 /* We've picked up everything up to the directory file name.
6342 Now just add the type and version, and we're set. */
6344 /* We should only add type for VMS syntax, but historically Perl
6345 has added it for UNIX style also */
6347 /* Fix me - we should not be using the same routine for VMS and
6348 UNIX format files. Things are too tangled so we need to lookup
6349 what syntax the output is */
6353 lastdir = strrchr(trndir,'/');
6357 lastdir = strpbrk(trndir,"]:>");
6363 if ((is_vms == 0) && (is_unix == 0)) {
6364 /* We still do not know? */
6365 is_unix = decc_filename_unix_report;
6370 if ((is_unix && !decc_efs_charset) || is_vms) {
6372 /* It is a bug to add a .dir to a UNIX format directory spec */
6373 /* However Perl on VMS may have programs that expect this so */
6374 /* If not using EFS character specifications allow it. */
6376 if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6377 /* Traditionally Perl expects filenames in lower case */
6378 strcat(buf, ".dir");
6380 /* VMS expects the .DIR to be in upper case */
6381 strcat(buf, ".DIR");
6384 /* It is also a bug to put a VMS format version on a UNIX file */
6385 /* specification. Perl self tests are looking for this */
6386 if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6389 PerlMem_free(trndir);
6390 PerlMem_free(vmsdir);
6393 else { /* VMS-style directory spec */
6395 char *esa, *esal, term, *cp;
6398 unsigned long int sts, cmplen, haslower = 0;
6399 unsigned int nam_fnb;
6401 struct FAB dirfab = cc$rms_fab;
6402 rms_setup_nam(savnam);
6403 rms_setup_nam(dirnam);
6405 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6406 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6408 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6409 esal = PerlMem_malloc(VMS_MAXRSS);
6410 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6412 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6413 rms_bind_fab_nam(dirfab, dirnam);
6414 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6415 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6416 #ifdef NAM$M_NO_SHORT_UPCASE
6417 if (decc_efs_case_preserve)
6418 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6421 for (cp = trndir; *cp; cp++)
6422 if (islower(*cp)) { haslower = 1; break; }
6423 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6424 if ((dirfab.fab$l_sts == RMS$_DIR) ||
6425 (dirfab.fab$l_sts == RMS$_DNF) ||
6426 (dirfab.fab$l_sts == RMS$_PRV)) {
6427 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6428 sts = sys$parse(&dirfab);
6434 PerlMem_free(trndir);
6435 PerlMem_free(vmsdir);
6437 set_vaxc_errno(dirfab.fab$l_sts);
6443 /* Does the file really exist? */
6444 if (sys$search(&dirfab)& STS$K_SUCCESS) {
6445 /* Yes; fake the fnb bits so we'll check type below */
6446 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6448 else { /* No; just work with potential name */
6449 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6452 fab_sts = dirfab.fab$l_sts;
6453 sts = rms_free_search_context(&dirfab);
6457 PerlMem_free(trndir);
6458 PerlMem_free(vmsdir);
6459 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
6465 /* Make sure we are using the right buffer */
6466 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6469 my_esa_len = rms_nam_esll(dirnam);
6473 my_esa_len = rms_nam_esl(dirnam);
6474 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6477 my_esa[my_esa_len] = '\0';
6478 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6479 cp1 = strchr(my_esa,']');
6480 if (!cp1) cp1 = strchr(my_esa,'>');
6481 if (cp1) { /* Should always be true */
6482 my_esa_len -= cp1 - my_esa - 1;
6483 memmove(my_esa, cp1 + 1, my_esa_len);
6486 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6487 /* Yep; check version while we're at it, if it's there. */
6488 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6489 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6490 /* Something other than .DIR[;1]. Bzzt. */
6491 sts = rms_free_search_context(&dirfab);
6495 PerlMem_free(trndir);
6496 PerlMem_free(vmsdir);
6498 set_vaxc_errno(RMS$_DIR);
6503 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6504 /* They provided at least the name; we added the type, if necessary, */
6505 strcpy(buf, my_esa);
6506 sts = rms_free_search_context(&dirfab);
6507 PerlMem_free(trndir);
6511 PerlMem_free(vmsdir);
6514 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6515 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6519 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6520 if (cp1 == NULL) { /* should never happen */
6521 sts = rms_free_search_context(&dirfab);
6522 PerlMem_free(trndir);
6526 PerlMem_free(vmsdir);
6531 retlen = strlen(my_esa);
6532 cp1 = strrchr(my_esa,'.');
6533 /* ODS-5 directory specifications can have extra "." in them. */
6534 /* Fix-me, can not scan EFS file specifications backwards */
6535 while (cp1 != NULL) {
6536 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6540 while ((cp1 > my_esa) && (*cp1 != '.'))
6547 if ((cp1) != NULL) {
6548 /* There's more than one directory in the path. Just roll back. */
6550 strcpy(buf, my_esa);
6553 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6554 /* Go back and expand rooted logical name */
6555 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6556 #ifdef NAM$M_NO_SHORT_UPCASE
6557 if (decc_efs_case_preserve)
6558 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6560 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6561 sts = rms_free_search_context(&dirfab);
6565 PerlMem_free(trndir);
6566 PerlMem_free(vmsdir);
6568 set_vaxc_errno(dirfab.fab$l_sts);
6572 /* This changes the length of the string of course */
6574 my_esa_len = rms_nam_esll(dirnam);
6576 my_esa_len = rms_nam_esl(dirnam);
6579 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6580 cp1 = strstr(my_esa,"][");
6581 if (!cp1) cp1 = strstr(my_esa,"]<");
6582 dirlen = cp1 - my_esa;
6583 memcpy(buf, my_esa, dirlen);
6584 if (!strncmp(cp1+2,"000000]",7)) {
6585 buf[dirlen-1] = '\0';
6586 /* fix-me Not full ODS-5, just extra dots in directories for now */
6587 cp1 = buf + dirlen - 1;
6593 if (*(cp1-1) != '^')
6598 if (*cp1 == '.') *cp1 = ']';
6600 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6601 memmove(cp1+1,"000000]",7);
6605 memmove(buf+dirlen, cp1+2, retlen-dirlen);
6607 /* Convert last '.' to ']' */
6609 while (*cp != '[') {
6612 /* Do not trip on extra dots in ODS-5 directories */
6613 if ((cp1 == buf) || (*(cp1-1) != '^'))
6617 if (*cp1 == '.') *cp1 = ']';
6619 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6620 memmove(cp1+1,"000000]",7);
6624 else { /* This is a top-level dir. Add the MFD to the path. */
6627 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6628 strcpy(cp2,":[000000]");
6633 sts = rms_free_search_context(&dirfab);
6634 /* We've set up the string up through the filename. Add the
6635 type and version, and we're done. */
6636 strcat(buf,".DIR;1");
6638 /* $PARSE may have upcased filespec, so convert output to lower
6639 * case if input contained any lowercase characters. */
6640 if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6641 PerlMem_free(trndir);
6645 PerlMem_free(vmsdir);
6648 } /* end of int_fileify_dirspec() */
6651 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6652 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6654 static char __fileify_retbuf[VMS_MAXRSS];
6655 char * fileified, *ret_spec, *ret_buf;
6659 if (ret_buf == NULL) {
6661 Newx(fileified, VMS_MAXRSS, char);
6662 if (fileified == NULL)
6663 _ckvmssts(SS$_INSFMEM);
6664 ret_buf = fileified;
6666 ret_buf = __fileify_retbuf;
6670 ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6672 if (ret_spec == NULL) {
6673 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6675 Safefree(fileified);
6679 } /* end of do_fileify_dirspec() */
6682 /* External entry points */
6683 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6684 { return do_fileify_dirspec(dir,buf,0,NULL); }
6685 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6686 { return do_fileify_dirspec(dir,buf,1,NULL); }
6687 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6688 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6689 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6690 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6692 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6693 char * v_spec, int v_len, char * r_spec, int r_len,
6694 char * d_spec, int d_len, char * n_spec, int n_len,
6695 char * e_spec, int e_len, char * vs_spec, int vs_len) {
6697 /* VMS specification - Try to do this the simple way */
6698 if ((v_len + r_len > 0) || (d_len > 0)) {
6701 /* No name or extension component, already a directory */
6702 if ((n_len + e_len + vs_len) == 0) {
6707 /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6708 /* This results from catfile() being used instead of catdir() */
6709 /* So even though it should not work, we need to allow it */
6711 /* If this is .DIR;1 then do a simple conversion */
6712 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6713 if (is_dir || (e_len == 0) && (d_len > 0)) {
6715 len = v_len + r_len + d_len - 1;
6716 char dclose = d_spec[d_len - 1];
6717 strncpy(buf, dir, len);
6720 strncpy(&buf[len], n_spec, n_len);
6723 buf[len + 1] = '\0';
6728 else if (d_len > 0) {
6729 /* In the olden days, a directory needed to have a .DIR */
6730 /* extension to be a valid directory, but now it could */
6731 /* be a symbolic link */
6733 len = v_len + r_len + d_len - 1;
6734 char dclose = d_spec[d_len - 1];
6735 strncpy(buf, dir, len);
6738 strncpy(&buf[len], n_spec, n_len);
6741 if (decc_efs_charset) {
6744 strncpy(&buf[len], e_spec, e_len);
6747 set_vaxc_errno(RMS$_DIR);
6753 buf[len + 1] = '\0';
6758 set_vaxc_errno(RMS$_DIR);
6764 set_vaxc_errno(RMS$_DIR);
6770 /* Internal routine to make sure or convert a directory to be in a */
6771 /* path specification. No utf8 flag because it is not changed or used */
6772 static char *int_pathify_dirspec(const char *dir, char *buf)
6774 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6775 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6776 char * exp_spec, *ret_spec;
6778 unsigned short int trnlnm_iter_count;
6782 if (vms_debug_fileify) {
6784 fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6786 fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6789 /* We may need to lower case the result if we translated */
6790 /* a logical name or got the current working directory */
6793 if (!dir || !*dir) {
6795 set_vaxc_errno(SS$_BADPARAM);
6799 trndir = PerlMem_malloc(VMS_MAXRSS);
6801 _ckvmssts_noperl(SS$_INSFMEM);
6803 /* If no directory specified use the current default */
6805 strcpy(trndir, dir);
6807 getcwd(trndir, VMS_MAXRSS - 1);
6811 /* now deal with bare names that could be logical names */
6812 trnlnm_iter_count = 0;
6813 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6814 && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6815 trnlnm_iter_count++;
6817 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6819 trnlen = strlen(trndir);
6821 /* Trap simple rooted lnms, and return lnm:[000000] */
6822 if (!strcmp(trndir+trnlen-2,".]")) {
6824 strcat(buf, ":[000000]");
6825 PerlMem_free(trndir);
6827 if (vms_debug_fileify) {
6828 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6834 /* At this point we do not work with *dir, but the copy in *trndir */
6836 if (need_to_lower && !decc_efs_case_preserve) {
6837 /* Legacy mode, lower case the returned value */
6838 __mystrtolower(trndir);
6842 /* Some special cases, '..', '.' */
6844 if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6845 /* Force UNIX filespec */
6849 /* Is this Unix or VMS format? */
6850 sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6851 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6852 &e_len, &vs_spec, &vs_len);
6855 /* Just a filename? */
6856 if ((v_len + r_len + d_len) == 0) {
6858 /* Now we have a problem, this could be Unix or VMS */
6859 /* We have to guess. .DIR usually means VMS */
6861 /* In UNIX report mode, the .DIR extension is removed */
6862 /* if one shows up, it is for a non-directory or a directory */
6863 /* in EFS charset mode */
6865 /* So if we are in Unix report mode, assume that this */
6866 /* is a relative Unix directory specification */
6869 if (!decc_filename_unix_report && decc_efs_charset) {
6871 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6874 /* Traditional mode, assume .DIR is directory */
6877 strncpy(&buf[2], n_spec, n_len);
6878 buf[n_len + 2] = ']';
6879 buf[n_len + 3] = '\0';
6880 PerlMem_free(trndir);
6881 if (vms_debug_fileify) {
6883 "int_pathify_dirspec: buf = %s\n",
6893 ret_spec = int_pathify_dirspec_simple(trndir, buf,
6894 v_spec, v_len, r_spec, r_len,
6895 d_spec, d_len, n_spec, n_len,
6896 e_spec, e_len, vs_spec, vs_len);
6898 if (ret_spec != NULL) {
6899 PerlMem_free(trndir);
6900 if (vms_debug_fileify) {
6902 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6907 /* Simple way did not work, which means that a logical name */
6908 /* was present for the directory specification. */
6909 /* Need to use an rmsexpand variant to decode it completely */
6910 exp_spec = PerlMem_malloc(VMS_MAXRSS);
6911 if (exp_spec == NULL)
6912 _ckvmssts_noperl(SS$_INSFMEM);
6914 ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6915 if (ret_spec != NULL) {
6916 sts = vms_split_path(exp_spec, &v_spec, &v_len,
6917 &r_spec, &r_len, &d_spec, &d_len,
6918 &n_spec, &n_len, &e_spec,
6919 &e_len, &vs_spec, &vs_len);
6921 ret_spec = int_pathify_dirspec_simple(
6922 exp_spec, buf, v_spec, v_len, r_spec, r_len,
6923 d_spec, d_len, n_spec, n_len,
6924 e_spec, e_len, vs_spec, vs_len);
6926 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6927 /* Legacy mode, lower case the returned value */
6928 __mystrtolower(ret_spec);
6931 set_vaxc_errno(RMS$_DIR);
6936 PerlMem_free(exp_spec);
6937 PerlMem_free(trndir);
6938 if (vms_debug_fileify) {
6939 if (ret_spec == NULL)
6940 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6943 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6948 /* Unix specification, Could be trivial conversion */
6950 dir_len = strlen(trndir);
6952 /* If the extended file character set is in effect */
6953 /* then pathify is simple */
6955 if (!decc_efs_charset) {
6956 /* Have to deal with traiing '.dir' or extra '.' */
6957 /* that should not be there in legacy mode, but is */
6963 lastslash = strrchr(trndir, '/');
6964 if (lastslash == NULL)
6971 /* '..' or '.' are valid directory components */
6973 if (lastslash[0] == '.') {
6974 if (lastslash[1] == '\0') {
6976 } else if (lastslash[1] == '.') {
6977 if (lastslash[2] == '\0') {
6980 /* And finally allow '...' */
6981 if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6989 lastdot = strrchr(lastslash, '.');
6991 if (lastdot != NULL) {
6994 /* '.dir' is discarded, and any other '.' is invalid */
6995 e_len = strlen(lastdot);
6997 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
7000 dir_len = dir_len - 4;
7006 strcpy(buf, trndir);
7007 if (buf[dir_len - 1] != '/') {
7009 buf[dir_len + 1] = '\0';
7012 /* Under ODS-2 rules, '.' becomes '_', so fix it up */
7013 if (!decc_efs_charset) {
7016 if (str[0] == '.') {
7019 while ((dots[cnt] == '.') && (cnt < 3))
7022 if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
7028 for (; *str; ++str) {
7029 while (*str == '/') {
7035 /* Have to skip up to three dots which could be */
7036 /* directories, 3 dots being a VMS extension for Perl */
7039 while ((dots[cnt] == '.') && (cnt < 3)) {
7042 if (dots[cnt] == '\0')
7044 if ((cnt > 1) && (dots[cnt] != '/')) {
7050 /* too many dots? */
7051 if ((cnt == 0) || (cnt > 3)) {
7055 if (!dir_start && (*str == '.')) {
7060 PerlMem_free(trndir);
7062 if (vms_debug_fileify) {
7063 if (ret_spec == NULL)
7064 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
7067 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
7073 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
7074 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
7076 static char __pathify_retbuf[VMS_MAXRSS];
7077 char * pathified, *ret_spec, *ret_buf;
7081 if (ret_buf == NULL) {
7083 Newx(pathified, VMS_MAXRSS, char);
7084 if (pathified == NULL)
7085 _ckvmssts(SS$_INSFMEM);
7086 ret_buf = pathified;
7088 ret_buf = __pathify_retbuf;
7092 ret_spec = int_pathify_dirspec(dir, ret_buf);
7094 if (ret_spec == NULL) {
7095 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7097 Safefree(pathified);
7102 } /* end of do_pathify_dirspec() */
7105 /* External entry points */
7106 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
7107 { return do_pathify_dirspec(dir,buf,0,NULL); }
7108 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
7109 { return do_pathify_dirspec(dir,buf,1,NULL); }
7110 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
7111 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
7112 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
7113 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
7115 /* Internal tounixspec routine that does not use a thread context */
7116 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7117 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7119 char *dirend, *cp1, *cp3, *tmp;
7121 int devlen, dirlen, retlen = VMS_MAXRSS;
7122 int expand = 1; /* guarantee room for leading and trailing slashes */
7123 unsigned short int trnlnm_iter_count;
7125 if (utf8_fl != NULL)
7128 if (vms_debug_fileify) {
7130 fprintf(stderr, "int_tounixspec: spec = NULL\n");
7132 fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7138 set_vaxc_errno(SS$_BADPARAM);
7141 if (strlen(spec) > (VMS_MAXRSS-1)) {
7143 set_vaxc_errno(SS$_BUFFEROVF);
7147 /* New VMS specific format needs translation
7148 * glob passes filenames with trailing '\n' and expects this preserved.
7150 if (decc_posix_compliant_pathnames) {
7151 if (strncmp(spec, "\"^UP^", 5) == 0) {
7157 tunix = PerlMem_malloc(VMS_MAXRSS);
7158 if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7159 strcpy(tunix, spec);
7160 tunix_len = strlen(tunix);
7162 if (tunix[tunix_len - 1] == '\n') {
7163 tunix[tunix_len - 1] = '\"';
7164 tunix[tunix_len] = '\0';
7168 uspec = decc$translate_vms(tunix);
7169 PerlMem_free(tunix);
7170 if ((int)uspec > 0) {
7176 /* If we can not translate it, makemaker wants as-is */
7184 cmp_rslt = 0; /* Presume VMS */
7185 cp1 = strchr(spec, '/');
7189 /* Look for EFS ^/ */
7190 if (decc_efs_charset) {
7191 while (cp1 != NULL) {
7194 /* Found illegal VMS, assume UNIX */
7199 cp1 = strchr(cp1, '/');
7203 /* Look for "." and ".." */
7204 if (decc_filename_unix_report) {
7205 if (spec[0] == '.') {
7206 if ((spec[1] == '\0') || (spec[1] == '\n')) {
7210 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7216 /* This is already UNIX or at least nothing VMS understands */
7219 if (vms_debug_fileify) {
7220 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7227 dirend = strrchr(spec,']');
7228 if (dirend == NULL) dirend = strrchr(spec,'>');
7229 if (dirend == NULL) dirend = strchr(spec,':');
7230 if (dirend == NULL) {
7232 if (vms_debug_fileify) {
7233 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7238 /* Special case 1 - sys$posix_root = / */
7239 #if __CRTL_VER >= 70000000
7240 if (!decc_disable_posix_root) {
7241 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7249 /* Special case 2 - Convert NLA0: to /dev/null */
7250 #if __CRTL_VER < 70000000
7251 cmp_rslt = strncmp(spec,"NLA0:", 5);
7253 cmp_rslt = strncmp(spec,"nla0:", 5);
7255 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7257 if (cmp_rslt == 0) {
7258 strcpy(rslt, "/dev/null");
7261 if (spec[6] != '\0') {
7268 /* Also handle special case "SYS$SCRATCH:" */
7269 #if __CRTL_VER < 70000000
7270 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7272 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7274 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7276 tmp = PerlMem_malloc(VMS_MAXRSS);
7277 if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7278 if (cmp_rslt == 0) {
7281 islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7283 strcpy(rslt, "/tmp");
7286 if (spec[12] != '\0') {
7294 if (*cp2 != '[' && *cp2 != '<') {
7297 else { /* the VMS spec begins with directories */
7299 if (*cp2 == ']' || *cp2 == '>') {
7300 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7304 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7305 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7307 if (vms_debug_fileify) {
7308 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7312 trnlnm_iter_count = 0;
7315 while (*cp3 != ':' && *cp3) cp3++;
7317 if (strchr(cp3,']') != NULL) break;
7318 trnlnm_iter_count++;
7319 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7320 } while (vmstrnenv(tmp,tmp,0,fildev,0));
7325 *(cp1++) = *(cp3++);
7326 if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7328 set_errno(ENAMETOOLONG);
7329 set_vaxc_errno(SS$_BUFFEROVF);
7330 if (vms_debug_fileify) {
7331 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7333 return NULL; /* No room */
7338 if ((*cp2 == '^')) {
7339 /* EFS file escape, pass the next character as is */
7340 /* Fix me: HEX encoding for Unicode not implemented */
7343 else if ( *cp2 == '.') {
7344 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7345 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7352 for (; cp2 <= dirend; cp2++) {
7353 if ((*cp2 == '^')) {
7354 /* EFS file escape, pass the next character as is */
7355 /* Fix me: HEX encoding for Unicode not implemented */
7356 *(cp1++) = *(++cp2);
7357 /* An escaped dot stays as is -- don't convert to slash */
7358 if (*cp2 == '.') cp2++;
7362 if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7364 else if (*cp2 == ']' || *cp2 == '>') {
7365 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7367 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7369 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7370 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7371 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7372 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7373 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7375 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7376 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7380 else if (*cp2 == '-') {
7381 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7382 while (*cp2 == '-') {
7384 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7386 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7387 /* filespecs like */
7388 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
7389 if (vms_debug_fileify) {
7390 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7395 else *(cp1++) = *cp2;
7397 else *(cp1++) = *cp2;
7399 /* Translate the rest of the filename. */
7404 /* Fixme - for compatibility with the CRTL we should be removing */
7405 /* spaces from the file specifications, but this may show that */
7406 /* some tests that were appearing to pass are not really passing */
7412 /* Fix me hex expansions not implemented */
7413 cp2++; /* '^.' --> '.' and other. */
7419 *(cp1++) = *(cp2++);
7424 if (decc_filename_unix_no_version) {
7425 /* Easy, drop the version */
7430 /* Punt - passing the version as a dot will probably */
7431 /* break perl in weird ways, but so did passing */
7432 /* through the ; as a version. Follow the CRTL and */
7433 /* hope for the best. */
7440 /* We will need to fix this properly later */
7441 /* As Perl may be installed on an ODS-5 volume, but not */
7442 /* have the EFS_CHARSET enabled, it still may encounter */
7443 /* filenames with extra dots in them, and a precedent got */
7444 /* set which allowed them to work, that we will uphold here */
7445 /* If extra dots are present in a name and no ^ is on them */
7446 /* VMS assumes that the first one is the extension delimiter */
7447 /* the rest have an implied ^. */
7449 /* this is also a conflict as the . is also a version */
7450 /* delimiter in VMS, */
7452 *(cp1++) = *(cp2++);
7456 /* This is an extension */
7457 if (decc_readdir_dropdotnotype) {
7459 if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7460 /* Drop the dot for the extension */
7468 *(cp1++) = *(cp2++);
7473 /* This still leaves /000000/ when working with a
7474 * VMS device root or concealed root.
7480 ulen = strlen(rslt);
7482 /* Get rid of "000000/ in rooted filespecs */
7484 zeros = strstr(rslt, "/000000/");
7485 if (zeros != NULL) {
7487 mlen = ulen - (zeros - rslt) - 7;
7488 memmove(zeros, &zeros[7], mlen);
7495 if (vms_debug_fileify) {
7496 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7500 } /* end of int_tounixspec() */
7503 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7504 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7506 static char __tounixspec_retbuf[VMS_MAXRSS];
7507 char * unixspec, *ret_spec, *ret_buf;
7511 if (ret_buf == NULL) {
7513 Newx(unixspec, VMS_MAXRSS, char);
7514 if (unixspec == NULL)
7515 _ckvmssts(SS$_INSFMEM);
7518 ret_buf = __tounixspec_retbuf;
7522 ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7524 if (ret_spec == NULL) {
7525 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7532 } /* end of do_tounixspec() */
7534 /* External entry points */
7535 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7536 { return do_tounixspec(spec,buf,0, NULL); }
7537 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7538 { return do_tounixspec(spec,buf,1, NULL); }
7539 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7540 { return do_tounixspec(spec,buf,0, utf8_fl); }
7541 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7542 { return do_tounixspec(spec,buf,1, utf8_fl); }
7544 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7547 This procedure is used to identify if a path is based in either
7548 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7549 it returns the OpenVMS format directory for it.
7551 It is expecting specifications of only '/' or '/xxxx/'
7553 If a posix root does not exist, or 'xxxx' is not a directory
7554 in the posix root, it returns a failure.
7556 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7558 It is used only internally by posix_to_vmsspec_hardway().
7561 static int posix_root_to_vms
7562 (char *vmspath, int vmspath_len,
7563 const char *unixpath,
7564 const int * utf8_fl)
7567 struct FAB myfab = cc$rms_fab;
7568 rms_setup_nam(mynam);
7569 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7570 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7571 char * esa, * esal, * rsa, * rsal;
7578 unixlen = strlen(unixpath);
7583 #if __CRTL_VER >= 80200000
7584 /* If not a posix spec already, convert it */
7585 if (decc_posix_compliant_pathnames) {
7586 if (strncmp(unixpath,"\"^UP^",5) != 0) {
7587 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7590 /* This is already a VMS specification, no conversion */
7592 strncpy(vmspath,unixpath, vmspath_len);
7601 /* Check to see if this is under the POSIX root */
7602 if (decc_disable_posix_root) {
7606 /* Skip leading / */
7607 if (unixpath[0] == '/') {
7613 strcpy(vmspath,"SYS$POSIX_ROOT:");
7615 /* If this is only the / , or blank, then... */
7616 if (unixpath[0] == '\0') {
7617 /* by definition, this is the answer */
7621 /* Need to look up a directory */
7625 /* Copy and add '^' escape characters as needed */
7628 while (unixpath[i] != 0) {
7631 j += copy_expand_unix_filename_escape
7632 (&vmspath[j], &unixpath[i], &k, utf8_fl);
7636 path_len = strlen(vmspath);
7637 if (vmspath[path_len - 1] == '/')
7639 vmspath[path_len] = ']';
7641 vmspath[path_len] = '\0';
7644 vmspath[vmspath_len] = 0;
7645 if (unixpath[unixlen - 1] == '/')
7647 esal = PerlMem_malloc(VMS_MAXRSS);
7648 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7649 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7650 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7651 rsal = PerlMem_malloc(VMS_MAXRSS);
7652 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7653 rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7654 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7655 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7656 rms_bind_fab_nam(myfab, mynam);
7657 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7658 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7659 if (decc_efs_case_preserve)
7660 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7661 #ifdef NAML$M_OPEN_SPECIAL
7662 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7665 /* Set up the remaining naml fields */
7666 sts = sys$parse(&myfab);
7668 /* It failed! Try again as a UNIX filespec */
7677 /* get the Device ID and the FID */
7678 sts = sys$search(&myfab);
7680 /* These are no longer needed */
7685 /* on any failure, returned the POSIX ^UP^ filespec */
7690 specdsc.dsc$a_pointer = vmspath;
7691 specdsc.dsc$w_length = vmspath_len;
7693 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7694 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7695 sts = lib$fid_to_name
7696 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7698 /* on any failure, returned the POSIX ^UP^ filespec */
7700 /* This can happen if user does not have permission to read directories */
7701 if (strncmp(unixpath,"\"^UP^",5) != 0)
7702 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7704 strcpy(vmspath, unixpath);
7707 vmspath[specdsc.dsc$w_length] = 0;
7709 /* Are we expecting a directory? */
7710 if (dir_flag != 0) {
7716 i = specdsc.dsc$w_length - 1;
7720 /* Version must be '1' */
7721 if (vmspath[i--] != '1')
7723 /* Version delimiter is one of ".;" */
7724 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7727 if (vmspath[i--] != 'R')
7729 if (vmspath[i--] != 'I')
7731 if (vmspath[i--] != 'D')
7733 if (vmspath[i--] != '.')
7735 eptr = &vmspath[i+1];
7737 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7738 if (vmspath[i-1] != '^') {
7746 /* Get rid of 6 imaginary zero directory filename */
7747 vmspath[i+1] = '\0';
7751 if (vmspath[i] == '0')
7765 /* /dev/mumble needs to be handled special.
7766 /dev/null becomes NLA0:, And there is the potential for other stuff
7767 like /dev/tty which may need to be mapped to something.
7771 slash_dev_special_to_vms
7772 (const char * unixptr,
7782 nextslash = strchr(unixptr, '/');
7783 len = strlen(unixptr);
7784 if (nextslash != NULL)
7785 len = nextslash - unixptr;
7786 cmp = strncmp("null", unixptr, 5);
7788 if (vmspath_len >= 6) {
7789 strcpy(vmspath, "_NLA0:");
7796 /* The built in routines do not understand perl's special needs, so
7797 doing a manual conversion from UNIX to VMS
7799 If the utf8_fl is not null and points to a non-zero value, then
7800 treat 8 bit characters as UTF-8.
7802 The sequence starting with '$(' and ending with ')' will be passed
7803 through with out interpretation instead of being escaped.
7806 static int posix_to_vmsspec_hardway
7807 (char *vmspath, int vmspath_len,
7808 const char *unixpath,
7813 const char *unixptr;
7814 const char *unixend;
7816 const char *lastslash;
7817 const char *lastdot;
7823 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7824 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7826 if (utf8_fl != NULL)
7832 /* Ignore leading "/" characters */
7833 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7836 unixlen = strlen(unixptr);
7838 /* Do nothing with blank paths */
7845 /* This could have a "^UP^ on the front */
7846 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7852 lastslash = strrchr(unixptr,'/');
7853 lastdot = strrchr(unixptr,'.');
7854 unixend = strrchr(unixptr,'\"');
7855 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7856 unixend = unixptr + unixlen;
7859 /* last dot is last dot or past end of string */
7860 if (lastdot == NULL)
7861 lastdot = unixptr + unixlen;
7863 /* if no directories, set last slash to beginning of string */
7864 if (lastslash == NULL) {
7865 lastslash = unixptr;
7868 /* Watch out for trailing "." after last slash, still a directory */
7869 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7870 lastslash = unixptr + unixlen;
7873 /* Watch out for traiing ".." after last slash, still a directory */
7874 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7875 lastslash = unixptr + unixlen;
7878 /* dots in directories are aways escaped */
7879 if (lastdot < lastslash)
7880 lastdot = unixptr + unixlen;
7883 /* if (unixptr < lastslash) then we are in a directory */
7890 /* Start with the UNIX path */
7891 if (*unixptr != '/') {
7892 /* relative paths */
7894 /* If allowing logical names on relative pathnames, then handle here */
7895 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7896 !decc_posix_compliant_pathnames) {
7902 /* Find the next slash */
7903 nextslash = strchr(unixptr,'/');
7905 esa = PerlMem_malloc(vmspath_len);
7906 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7908 trn = PerlMem_malloc(VMS_MAXRSS);
7909 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7911 if (nextslash != NULL) {
7913 seg_len = nextslash - unixptr;
7914 strncpy(esa, unixptr, seg_len);
7918 strcpy(esa, unixptr);
7919 seg_len = strlen(unixptr);
7921 /* trnlnm(section) */
7922 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7925 /* Now fix up the directory */
7927 /* Split up the path to find the components */
7928 sts = vms_split_path
7947 /* A logical name must be a directory or the full
7948 specification. It is only a full specification if
7949 it is the only component */
7950 if ((unixptr[seg_len] == '\0') ||
7951 (unixptr[seg_len+1] == '\0')) {
7953 /* Is a directory being required? */
7954 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7955 /* Not a logical name */
7960 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7961 /* This must be a directory */
7962 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7963 strcpy(vmsptr, esa);
7964 vmslen=strlen(vmsptr);
7965 vmsptr[vmslen] = ':';
7967 vmsptr[vmslen] = '\0';
7975 /* must be dev/directory - ignore version */
7976 if ((n_len + e_len) != 0)
7979 /* transfer the volume */
7980 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7981 strncpy(vmsptr, v_spec, v_len);
7987 /* unroot the rooted directory */
7988 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7990 r_spec[r_len - 1] = ']';
7992 /* This should not be there, but nothing is perfect */
7994 cmp = strcmp(&r_spec[1], "000000.");
8004 strncpy(vmsptr, r_spec, r_len);
8010 /* Bring over the directory. */
8012 ((d_len + vmslen) < vmspath_len)) {
8014 d_spec[d_len - 1] = ']';
8016 cmp = strcmp(&d_spec[1], "000000.");
8027 /* Remove the redundant root */
8035 strncpy(vmsptr, d_spec, d_len);
8049 if (lastslash > unixptr) {
8052 /* skip leading ./ */
8054 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
8060 /* Are we still in a directory? */
8061 if (unixptr <= lastslash) {
8066 /* if not backing up, then it is relative forward. */
8067 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
8068 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
8076 /* Perl wants an empty directory here to tell the difference
8077 * between a DCL commmand and a filename
8086 /* Handle two special files . and .. */
8087 if (unixptr[0] == '.') {
8088 if (&unixptr[1] == unixend) {
8095 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
8106 else { /* Absolute PATH handling */
8110 /* Need to find out where root is */
8112 /* In theory, this procedure should never get an absolute POSIX pathname
8113 * that can not be found on the POSIX root.
8114 * In practice, that can not be relied on, and things will show up
8115 * here that are a VMS device name or concealed logical name instead.
8116 * So to make things work, this procedure must be tolerant.
8118 esa = PerlMem_malloc(vmspath_len);
8119 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8122 nextslash = strchr(&unixptr[1],'/');
8124 if (nextslash != NULL) {
8126 seg_len = nextslash - &unixptr[1];
8127 strncpy(vmspath, unixptr, seg_len + 1);
8128 vmspath[seg_len+1] = 0;
8131 cmp = strncmp(vmspath, "dev", 4);
8133 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8134 if (sts = SS$_NORMAL)
8138 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8141 if ($VMS_STATUS_SUCCESS(sts)) {
8142 /* This is verified to be a real path */
8144 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8145 if ($VMS_STATUS_SUCCESS(sts)) {
8146 strcpy(vmspath, esa);
8147 vmslen = strlen(vmspath);
8148 vmsptr = vmspath + vmslen;
8150 if (unixptr < lastslash) {
8159 cmp = strcmp(rptr,"000000.");
8164 } /* removing 6 zeros */
8165 } /* vmslen < 7, no 6 zeros possible */
8166 } /* Not in a directory */
8167 } /* Posix root found */
8169 /* No posix root, fall back to default directory */
8170 strcpy(vmspath, "SYS$DISK:[");
8171 vmsptr = &vmspath[10];
8173 if (unixptr > lastslash) {
8182 } /* end of verified real path handling */
8187 /* Ok, we have a device or a concealed root that is not in POSIX
8188 * or we have garbage. Make the best of it.
8191 /* Posix to VMS destroyed this, so copy it again */
8192 strncpy(vmspath, &unixptr[1], seg_len);
8193 vmspath[seg_len] = 0;
8195 vmsptr = &vmsptr[vmslen];
8198 /* Now do we need to add the fake 6 zero directory to it? */
8200 if ((*lastslash == '/') && (nextslash < lastslash)) {
8201 /* No there is another directory */
8208 /* now we have foo:bar or foo:[000000]bar to decide from */
8209 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8211 if (!islnm && !decc_posix_compliant_pathnames) {
8213 cmp = strncmp("bin", vmspath, 4);
8215 /* bin => SYS$SYSTEM: */
8216 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8219 /* tmp => SYS$SCRATCH: */
8220 cmp = strncmp("tmp", vmspath, 4);
8222 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8227 trnend = islnm ? islnm - 1 : 0;
8229 /* if this was a logical name, ']' or '>' must be present */
8230 /* if not a logical name, then assume a device and hope. */
8231 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8233 /* if log name and trailing '.' then rooted - treat as device */
8234 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8236 /* Fix me, if not a logical name, a device lookup should be
8237 * done to see if the device is file structured. If the device
8238 * is not file structured, the 6 zeros should not be put on.
8240 * As it is, perl is occasionally looking for dev:[000000]tty.
8241 * which looks a little strange.
8243 * Not that easy to detect as "/dev" may be file structured with
8244 * special device files.
8247 if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
8248 (&nextslash[1] == unixend)) {
8249 /* No real directory present */
8254 /* Put the device delimiter on */
8257 unixptr = nextslash;
8260 /* Start directory if needed */
8261 if (!islnm || add_6zero) {
8267 /* add fake 000000] if needed */
8280 } /* non-POSIX translation */
8282 } /* End of relative/absolute path handling */
8284 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8291 if (dir_start != 0) {
8293 /* First characters in a directory are handled special */
8294 while ((*unixptr == '/') ||
8295 ((*unixptr == '.') &&
8296 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8297 (&unixptr[1]==unixend)))) {
8302 /* Skip redundant / in specification */
8303 while ((*unixptr == '/') && (dir_start != 0)) {
8306 if (unixptr == lastslash)
8309 if (unixptr == lastslash)
8312 /* Skip redundant ./ characters */
8313 while ((*unixptr == '.') &&
8314 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8317 if (unixptr == lastslash)
8319 if (*unixptr == '/')
8322 if (unixptr == lastslash)
8325 /* Skip redundant ../ characters */
8326 while ((*unixptr == '.') && (unixptr[1] == '.') &&
8327 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8328 /* Set the backing up flag */
8334 unixptr++; /* first . */
8335 unixptr++; /* second . */
8336 if (unixptr == lastslash)
8338 if (*unixptr == '/') /* The slash */
8341 if (unixptr == lastslash)
8344 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8345 /* Not needed when VMS is pretending to be UNIX. */
8347 /* Is this loop stuck because of too many dots? */
8348 if (loop_flag == 0) {
8349 /* Exit the loop and pass the rest through */
8354 /* Are we done with directories yet? */
8355 if (unixptr >= lastslash) {
8357 /* Watch out for trailing dots */
8366 if (*unixptr == '/')
8370 /* Have we stopped backing up? */
8375 /* dir_start continues to be = 1 */
8377 if (*unixptr == '-') {
8379 *vmsptr++ = *unixptr++;
8383 /* Now are we done with directories yet? */
8384 if (unixptr >= lastslash) {
8386 /* Watch out for trailing dots */
8402 if (unixptr >= unixend)
8405 /* Normal characters - More EFS work probably needed */
8411 /* remove multiple / */
8412 while (unixptr[1] == '/') {
8415 if (unixptr == lastslash) {
8416 /* Watch out for trailing dots */
8428 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8429 /* Not needed when VMS is pretending to be UNIX. */
8433 if (unixptr != unixend)
8438 if ((unixptr < lastdot) || (unixptr < lastslash) ||
8439 (&unixptr[1] == unixend)) {
8445 /* trailing dot ==> '^..' on VMS */
8446 if (unixptr == unixend) {
8454 *vmsptr++ = *unixptr++;
8458 if (quoted && (&unixptr[1] == unixend)) {
8462 in_cnt = copy_expand_unix_filename_escape
8463 (vmsptr, unixptr, &out_cnt, utf8_fl);
8473 in_cnt = copy_expand_unix_filename_escape
8474 (vmsptr, unixptr, &out_cnt, utf8_fl);
8481 /* Make sure directory is closed */
8482 if (unixptr == lastslash) {
8484 vmsptr2 = vmsptr - 1;
8486 if (*vmsptr2 != ']') {
8489 /* directories do not end in a dot bracket */
8490 if (*vmsptr2 == '.') {
8494 if (*vmsptr2 != '^') {
8495 vmsptr--; /* back up over the dot */
8503 /* Add a trailing dot if a file with no extension */
8504 vmsptr2 = vmsptr - 1;
8506 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8507 (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8518 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8519 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8524 /* If a UTF8 flag is being passed, honor it */
8526 if (utf8_fl != NULL) {
8527 utf8_flag = *utf8_fl;
8532 /* If there is a possibility of UTF8, then if any UTF8 characters
8533 are present, then they must be converted to VTF-7
8535 result = strcpy(rslt, path); /* FIX-ME */
8538 result = strcpy(rslt, path);
8545 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8546 static char *int_tovmsspec
8547 (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8553 unsigned long int infront = 0, hasdir = 1;
8556 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8557 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8559 if (vms_debug_fileify) {
8561 fprintf(stderr, "int_tovmsspec: path = NULL\n");
8563 fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8567 /* If we fail, we should be setting errno */
8569 set_vaxc_errno(SS$_BADPARAM);
8572 rslt_len = VMS_MAXRSS-1;
8574 /* '.' and '..' are "[]" and "[-]" for a quick check */
8575 if (path[0] == '.') {
8576 if (path[1] == '\0') {
8578 if (utf8_flag != NULL)
8583 if (path[1] == '.' && path[2] == '\0') {
8585 if (utf8_flag != NULL)
8592 /* Posix specifications are now a native VMS format */
8593 /*--------------------------------------------------*/
8594 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8595 if (decc_posix_compliant_pathnames) {
8596 if (strncmp(path,"\"^UP^",5) == 0) {
8597 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8603 /* This is really the only way to see if this is already in VMS format */
8604 sts = vms_split_path
8619 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8620 replacement, because the above parse just took care of most of
8621 what is needed to do vmspath when the specification is already
8624 And if it is not already, it is easier to do the conversion as
8625 part of this routine than to call this routine and then work on
8629 /* If VMS punctuation was found, it is already VMS format */
8630 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8631 if (utf8_flag != NULL)
8634 if (vms_debug_fileify) {
8635 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8639 /* Now, what to do with trailing "." cases where there is no
8640 extension? If this is a UNIX specification, and EFS characters
8641 are enabled, then the trailing "." should be converted to a "^.".
8642 But if this was already a VMS specification, then it should be
8645 So in the case of ambiguity, leave the specification alone.
8649 /* If there is a possibility of UTF8, then if any UTF8 characters
8650 are present, then they must be converted to VTF-7
8652 if (utf8_flag != NULL)
8655 if (vms_debug_fileify) {
8656 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8661 dirend = strrchr(path,'/');
8663 if (dirend == NULL) {
8667 /* If we get here with no UNIX directory delimiters, then this is
8668 not a complete file specification, either garbage a UNIX glob
8669 specification that can not be converted to a VMS wildcard, or
8670 it a UNIX shell macro. MakeMaker wants shell macros passed
8673 utf8 flag setting needs to be preserved.
8678 macro_start = strchr(path,'$');
8679 if (macro_start != NULL) {
8680 if (macro_start[1] == '(') {
8684 if ((decc_efs_charset == 0) || (has_macro)) {
8686 if (vms_debug_fileify) {
8687 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8693 /* If EFS charset mode active, handle the conversion */
8694 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8695 if (decc_efs_charset) {
8696 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8697 if (vms_debug_fileify) {
8698 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8704 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
8705 if (!*(dirend+2)) dirend +=2;
8706 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8707 if (decc_efs_charset == 0) {
8708 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8714 lastdot = strrchr(cp2,'.');
8720 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8722 if (decc_disable_posix_root) {
8723 strcpy(rslt,"sys$disk:[000000]");
8726 strcpy(rslt,"sys$posix_root:[000000]");
8728 if (utf8_flag != NULL)
8730 if (vms_debug_fileify) {
8731 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8735 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8737 trndev = PerlMem_malloc(VMS_MAXRSS);
8738 if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8739 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8741 /* DECC special handling */
8743 if (strcmp(rslt,"bin") == 0) {
8744 strcpy(rslt,"sys$system");
8747 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8749 else if (strcmp(rslt,"tmp") == 0) {
8750 strcpy(rslt,"sys$scratch");
8753 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8755 else if (!decc_disable_posix_root) {
8756 strcpy(rslt, "sys$posix_root");
8760 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8761 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8763 else if (strcmp(rslt,"dev") == 0) {
8764 if (strncmp(cp2,"/null", 5) == 0) {
8765 if ((cp2[5] == 0) || (cp2[5] == '/')) {
8766 strcpy(rslt,"NLA0");
8770 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8776 trnend = islnm ? strlen(trndev) - 1 : 0;
8777 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8778 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8779 /* If the first element of the path is a logical name, determine
8780 * whether it has to be translated so we can add more directories. */
8781 if (!islnm || rooted) {
8784 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8788 if (cp2 != dirend) {
8789 strcpy(rslt,trndev);
8790 cp1 = rslt + trnend;
8797 if (decc_disable_posix_root) {
8803 PerlMem_free(trndev);
8808 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8809 cp2 += 2; /* skip over "./" - it's redundant */
8810 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8812 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8813 *(cp1++) = '-'; /* "../" --> "-" */
8816 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8817 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8818 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8819 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8822 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8823 /* Escape the extra dots in EFS file specifications */
8826 if (cp2 > dirend) cp2 = dirend;
8828 else *(cp1++) = '.';
8830 for (; cp2 < dirend; cp2++) {
8832 if (*(cp2-1) == '/') continue;
8833 if (*(cp1-1) != '.') *(cp1++) = '.';
8836 else if (!infront && *cp2 == '.') {
8837 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8838 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
8839 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8840 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8841 else if (*(cp1-2) == '[') *(cp1-1) = '-';
8842 else { /* back up over previous directory name */
8844 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8845 if (*(cp1-1) == '[') {
8846 memcpy(cp1,"000000.",7);
8851 if (cp2 == dirend) break;
8853 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8854 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8855 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8856 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8858 *(cp1++) = '.'; /* Simulate trailing '/' */
8859 cp2 += 2; /* for loop will incr this to == dirend */
8861 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8864 if (decc_efs_charset == 0)
8865 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8867 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8873 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
8875 if (decc_efs_charset == 0)
8882 else *(cp1++) = *cp2;
8886 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8887 if (hasdir) *(cp1++) = ']';
8888 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
8889 /* fixme for ODS5 */
8896 if (decc_efs_charset == 0)
8907 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8908 decc_readdir_dropdotnotype) {
8913 /* trailing dot ==> '^..' on VMS */
8920 *(cp1++) = *(cp2++);
8925 /* This could be a macro to be passed through */
8926 *(cp1++) = *(cp2++);
8928 const char * save_cp2;
8932 /* paranoid check */
8938 *(cp1++) = *(cp2++);
8939 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8940 *(cp1++) = *(cp2++);
8941 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8942 *(cp1++) = *(cp2++);
8945 *(cp1++) = *(cp2++);
8949 if (is_macro == 0) {
8950 /* Not really a macro - never mind */
8963 /* Don't escape again if following character is
8964 * already something we escape.
8966 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8967 *(cp1++) = *(cp2++);
8970 /* But otherwise fall through and escape it. */
8988 *(cp1++) = *(cp2++);
8991 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8992 * which is wrong. UNIX notation should be ".dir." unless
8993 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8994 * changing this behavior could break more things at this time.
8995 * efs character set effectively does not allow "." to be a version
8996 * delimiter as a further complication about changing this.
8998 if (decc_filename_unix_report != 0) {
9001 *(cp1++) = *(cp2++);
9004 *(cp1++) = *(cp2++);
9007 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
9011 /* Fix me for "^]", but that requires making sure that you do
9012 * not back up past the start of the filename
9014 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
9019 if (utf8_flag != NULL)
9021 if (vms_debug_fileify) {
9022 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
9026 } /* end of int_tovmsspec() */
9029 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
9030 static char *mp_do_tovmsspec
9031 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
9032 static char __tovmsspec_retbuf[VMS_MAXRSS];
9033 char * vmsspec, *ret_spec, *ret_buf;
9037 if (ret_buf == NULL) {
9039 Newx(vmsspec, VMS_MAXRSS, char);
9040 if (vmsspec == NULL)
9041 _ckvmssts(SS$_INSFMEM);
9044 ret_buf = __tovmsspec_retbuf;
9048 ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
9050 if (ret_spec == NULL) {
9051 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
9058 } /* end of mp_do_tovmsspec() */
9060 /* External entry points */
9061 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
9062 { return do_tovmsspec(path,buf,0,NULL); }
9063 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
9064 { return do_tovmsspec(path,buf,1,NULL); }
9065 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9066 { return do_tovmsspec(path,buf,0,utf8_fl); }
9067 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9068 { return do_tovmsspec(path,buf,1,utf8_fl); }
9070 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
9071 /* Internal routine for use with out an explict context present */
9072 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
9074 char * ret_spec, *pathified;
9079 pathified = PerlMem_malloc(VMS_MAXRSS);
9080 if (pathified == NULL)
9081 _ckvmssts_noperl(SS$_INSFMEM);
9083 ret_spec = int_pathify_dirspec(path, pathified);
9085 if (ret_spec == NULL) {
9086 PerlMem_free(pathified);
9090 ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
9092 PerlMem_free(pathified);
9097 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
9098 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9099 static char __tovmspath_retbuf[VMS_MAXRSS];
9101 char *pathified, *vmsified, *cp;
9103 if (path == NULL) return NULL;
9104 pathified = PerlMem_malloc(VMS_MAXRSS);
9105 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9106 if (int_pathify_dirspec(path, pathified) == NULL) {
9107 PerlMem_free(pathified);
9113 Newx(vmsified, VMS_MAXRSS, char);
9114 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
9115 PerlMem_free(pathified);
9116 if (vmsified) Safefree(vmsified);
9119 PerlMem_free(pathified);
9124 vmslen = strlen(vmsified);
9125 Newx(cp,vmslen+1,char);
9126 memcpy(cp,vmsified,vmslen);
9132 strcpy(__tovmspath_retbuf,vmsified);
9134 return __tovmspath_retbuf;
9137 } /* end of do_tovmspath() */
9139 /* External entry points */
9140 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
9141 { return do_tovmspath(path,buf,0, NULL); }
9142 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9143 { return do_tovmspath(path,buf,1, NULL); }
9144 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9145 { return do_tovmspath(path,buf,0,utf8_fl); }
9146 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9147 { return do_tovmspath(path,buf,1,utf8_fl); }
9150 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9151 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9152 static char __tounixpath_retbuf[VMS_MAXRSS];
9154 char *pathified, *unixified, *cp;
9156 if (path == NULL) return NULL;
9157 pathified = PerlMem_malloc(VMS_MAXRSS);
9158 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9159 if (int_pathify_dirspec(path, pathified) == NULL) {
9160 PerlMem_free(pathified);
9166 Newx(unixified, VMS_MAXRSS, char);
9168 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9169 PerlMem_free(pathified);
9170 if (unixified) Safefree(unixified);
9173 PerlMem_free(pathified);
9178 unixlen = strlen(unixified);
9179 Newx(cp,unixlen+1,char);
9180 memcpy(cp,unixified,unixlen);
9182 Safefree(unixified);
9186 strcpy(__tounixpath_retbuf,unixified);
9187 Safefree(unixified);
9188 return __tounixpath_retbuf;
9191 } /* end of do_tounixpath() */
9193 /* External entry points */
9194 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
9195 { return do_tounixpath(path,buf,0,NULL); }
9196 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9197 { return do_tounixpath(path,buf,1,NULL); }
9198 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9199 { return do_tounixpath(path,buf,0,utf8_fl); }
9200 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9201 { return do_tounixpath(path,buf,1,utf8_fl); }
9204 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
9206 *****************************************************************************
9208 * Copyright (C) 1989-1994, 2007 by *
9209 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
9211 * Permission is hereby granted for the reproduction of this software *
9212 * on condition that this copyright notice is included in source *
9213 * distributions of the software. The code may be modified and *
9214 * distributed under the same terms as Perl itself. *
9216 * 27-Aug-1994 Modified for inclusion in perl5 *
9217 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
9218 *****************************************************************************
9222 * getredirection() is intended to aid in porting C programs
9223 * to VMS (Vax-11 C). The native VMS environment does not support
9224 * '>' and '<' I/O redirection, or command line wild card expansion,
9225 * or a command line pipe mechanism using the '|' AND background
9226 * command execution '&'. All of these capabilities are provided to any
9227 * C program which calls this procedure as the first thing in the
9229 * The piping mechanism will probably work with almost any 'filter' type
9230 * of program. With suitable modification, it may useful for other
9231 * portability problems as well.
9233 * Author: Mark Pizzolato (mark AT infocomm DOT com)
9237 struct list_item *next;
9241 static void add_item(struct list_item **head,
9242 struct list_item **tail,
9246 static void mp_expand_wild_cards(pTHX_ char *item,
9247 struct list_item **head,
9248 struct list_item **tail,
9251 static int background_process(pTHX_ int argc, char **argv);
9253 static void pipe_and_fork(pTHX_ char **cmargv);
9255 /*{{{ void getredirection(int *ac, char ***av)*/
9257 mp_getredirection(pTHX_ int *ac, char ***av)
9259 * Process vms redirection arg's. Exit if any error is seen.
9260 * If getredirection() processes an argument, it is erased
9261 * from the vector. getredirection() returns a new argc and argv value.
9262 * In the event that a background command is requested (by a trailing "&"),
9263 * this routine creates a background subprocess, and simply exits the program.
9265 * Warning: do not try to simplify the code for vms. The code
9266 * presupposes that getredirection() is called before any data is
9267 * read from stdin or written to stdout.
9269 * Normal usage is as follows:
9275 * getredirection(&argc, &argv);
9279 int argc = *ac; /* Argument Count */
9280 char **argv = *av; /* Argument Vector */
9281 char *ap; /* Argument pointer */
9282 int j; /* argv[] index */
9283 int item_count = 0; /* Count of Items in List */
9284 struct list_item *list_head = 0; /* First Item in List */
9285 struct list_item *list_tail; /* Last Item in List */
9286 char *in = NULL; /* Input File Name */
9287 char *out = NULL; /* Output File Name */
9288 char *outmode = "w"; /* Mode to Open Output File */
9289 char *err = NULL; /* Error File Name */
9290 char *errmode = "w"; /* Mode to Open Error File */
9291 int cmargc = 0; /* Piped Command Arg Count */
9292 char **cmargv = NULL;/* Piped Command Arg Vector */
9295 * First handle the case where the last thing on the line ends with
9296 * a '&'. This indicates the desire for the command to be run in a
9297 * subprocess, so we satisfy that desire.
9300 if (0 == strcmp("&", ap))
9301 exit(background_process(aTHX_ --argc, argv));
9302 if (*ap && '&' == ap[strlen(ap)-1])
9304 ap[strlen(ap)-1] = '\0';
9305 exit(background_process(aTHX_ argc, argv));
9308 * Now we handle the general redirection cases that involve '>', '>>',
9309 * '<', and pipes '|'.
9311 for (j = 0; j < argc; ++j)
9313 if (0 == strcmp("<", argv[j]))
9317 fprintf(stderr,"No input file after < on command line");
9318 exit(LIB$_WRONUMARG);
9323 if ('<' == *(ap = argv[j]))
9328 if (0 == strcmp(">", ap))
9332 fprintf(stderr,"No output file after > on command line");
9333 exit(LIB$_WRONUMARG);
9352 fprintf(stderr,"No output file after > or >> on command line");
9353 exit(LIB$_WRONUMARG);
9357 if (('2' == *ap) && ('>' == ap[1]))
9374 fprintf(stderr,"No output file after 2> or 2>> on command line");
9375 exit(LIB$_WRONUMARG);
9379 if (0 == strcmp("|", argv[j]))
9383 fprintf(stderr,"No command into which to pipe on command line");
9384 exit(LIB$_WRONUMARG);
9386 cmargc = argc-(j+1);
9387 cmargv = &argv[j+1];
9391 if ('|' == *(ap = argv[j]))
9399 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9402 * Allocate and fill in the new argument vector, Some Unix's terminate
9403 * the list with an extra null pointer.
9405 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9406 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9408 for (j = 0; j < item_count; ++j, list_head = list_head->next)
9409 argv[j] = list_head->value;
9415 fprintf(stderr,"'|' and '>' may not both be specified on command line");
9416 exit(LIB$_INVARGORD);
9418 pipe_and_fork(aTHX_ cmargv);
9421 /* Check for input from a pipe (mailbox) */
9423 if (in == NULL && 1 == isapipe(0))
9425 char mbxname[L_tmpnam];
9427 long int dvi_item = DVI$_DEVBUFSIZ;
9428 $DESCRIPTOR(mbxnam, "");
9429 $DESCRIPTOR(mbxdevnam, "");
9431 /* Input from a pipe, reopen it in binary mode to disable */
9432 /* carriage control processing. */
9434 fgetname(stdin, mbxname, 1);
9435 mbxnam.dsc$a_pointer = mbxname;
9436 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9437 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9438 mbxdevnam.dsc$a_pointer = mbxname;
9439 mbxdevnam.dsc$w_length = sizeof(mbxname);
9440 dvi_item = DVI$_DEVNAM;
9441 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9442 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9445 freopen(mbxname, "rb", stdin);
9448 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9452 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9454 fprintf(stderr,"Can't open input file %s as stdin",in);
9457 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9459 fprintf(stderr,"Can't open output file %s as stdout",out);
9462 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9465 if (strcmp(err,"&1") == 0) {
9466 dup2(fileno(stdout), fileno(stderr));
9467 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9470 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9472 fprintf(stderr,"Can't open error file %s as stderr",err);
9476 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9480 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9483 #ifdef ARGPROC_DEBUG
9484 PerlIO_printf(Perl_debug_log, "Arglist:\n");
9485 for (j = 0; j < *ac; ++j)
9486 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9488 /* Clear errors we may have hit expanding wildcards, so they don't
9489 show up in Perl's $! later */
9490 set_errno(0); set_vaxc_errno(1);
9491 } /* end of getredirection() */
9494 static void add_item(struct list_item **head,
9495 struct list_item **tail,
9501 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9502 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9506 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9507 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9508 *tail = (*tail)->next;
9510 (*tail)->value = value;
9514 static void mp_expand_wild_cards(pTHX_ char *item,
9515 struct list_item **head,
9516 struct list_item **tail,
9520 unsigned long int context = 0;
9528 $DESCRIPTOR(filespec, "");
9529 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9530 $DESCRIPTOR(resultspec, "");
9531 unsigned long int lff_flags = 0;
9535 #ifdef VMS_LONGNAME_SUPPORT
9536 lff_flags = LIB$M_FIL_LONG_NAMES;
9539 for (cp = item; *cp; cp++) {
9540 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9541 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9543 if (!*cp || isspace(*cp))
9545 add_item(head, tail, item, count);
9550 /* "double quoted" wild card expressions pass as is */
9551 /* From DCL that means using e.g.: */
9552 /* perl program """perl.*""" */
9553 item_len = strlen(item);
9554 if ( '"' == *item && '"' == item[item_len-1] )
9557 item[item_len-2] = '\0';
9558 add_item(head, tail, item, count);
9562 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9563 resultspec.dsc$b_class = DSC$K_CLASS_D;
9564 resultspec.dsc$a_pointer = NULL;
9565 vmsspec = PerlMem_malloc(VMS_MAXRSS);
9566 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9567 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9568 filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9569 if (!isunix || !filespec.dsc$a_pointer)
9570 filespec.dsc$a_pointer = item;
9571 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9573 * Only return version specs, if the caller specified a version
9575 had_version = strchr(item, ';');
9577 * Only return device and directory specs, if the caller specifed either.
9579 had_device = strchr(item, ':');
9580 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9582 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9583 (&filespec, &resultspec, &context,
9584 &defaultspec, 0, &rms_sts, &lff_flags)))
9589 string = PerlMem_malloc(resultspec.dsc$w_length+1);
9590 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9591 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9592 string[resultspec.dsc$w_length] = '\0';
9593 if (NULL == had_version)
9594 *(strrchr(string, ';')) = '\0';
9595 if ((!had_directory) && (had_device == NULL))
9597 if (NULL == (devdir = strrchr(string, ']')))
9598 devdir = strrchr(string, '>');
9599 strcpy(string, devdir + 1);
9602 * Be consistent with what the C RTL has already done to the rest of
9603 * the argv items and lowercase all of these names.
9605 if (!decc_efs_case_preserve) {
9606 for (c = string; *c; ++c)
9610 if (isunix) trim_unixpath(string,item,1);
9611 add_item(head, tail, string, count);
9614 PerlMem_free(vmsspec);
9615 if (sts != RMS$_NMF)
9617 set_vaxc_errno(sts);
9620 case RMS$_FNF: case RMS$_DNF:
9621 set_errno(ENOENT); break;
9623 set_errno(ENOTDIR); break;
9625 set_errno(ENODEV); break;
9626 case RMS$_FNM: case RMS$_SYN:
9627 set_errno(EINVAL); break;
9629 set_errno(EACCES); break;
9631 _ckvmssts_noperl(sts);
9635 add_item(head, tail, item, count);
9636 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9637 _ckvmssts_noperl(lib$find_file_end(&context));
9640 static int child_st[2];/* Event Flag set when child process completes */
9642 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
9644 static unsigned long int exit_handler(int *status)
9648 if (0 == child_st[0])
9650 #ifdef ARGPROC_DEBUG
9651 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9653 fflush(stdout); /* Have to flush pipe for binary data to */
9654 /* terminate properly -- <tp@mccall.com> */
9655 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9656 sys$dassgn(child_chan);
9658 sys$synch(0, child_st);
9663 static void sig_child(int chan)
9665 #ifdef ARGPROC_DEBUG
9666 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9668 if (child_st[0] == 0)
9672 static struct exit_control_block exit_block =
9677 &exit_block.exit_status,
9682 pipe_and_fork(pTHX_ char **cmargv)
9685 struct dsc$descriptor_s *vmscmd;
9686 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9687 int sts, j, l, ismcr, quote, tquote = 0;
9689 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
9690 vms_execfree(vmscmd);
9695 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
9696 && toupper(*(q+2)) == 'R' && !*(q+3);
9698 while (q && l < MAX_DCL_LINE_LENGTH) {
9700 if (j > 0 && quote) {
9706 if (ismcr && j > 1) quote = 1;
9707 tquote = (strchr(q,' ')) != NULL || *q == '\0';
9710 if (quote || tquote) {
9716 if ((quote||tquote) && *q == '"') {
9726 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9728 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9732 static int background_process(pTHX_ int argc, char **argv)
9734 char command[MAX_DCL_SYMBOL + 1] = "$";
9735 $DESCRIPTOR(value, "");
9736 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9737 static $DESCRIPTOR(null, "NLA0:");
9738 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9740 $DESCRIPTOR(pidstr, "");
9742 unsigned long int flags = 17, one = 1, retsts;
9745 strcat(command, argv[0]);
9746 len = strlen(command);
9747 while (--argc && (len < MAX_DCL_SYMBOL))
9749 strcat(command, " \"");
9750 strcat(command, *(++argv));
9751 strcat(command, "\"");
9752 len = strlen(command);
9754 value.dsc$a_pointer = command;
9755 value.dsc$w_length = strlen(value.dsc$a_pointer);
9756 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9757 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9758 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9759 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9762 _ckvmssts_noperl(retsts);
9764 #ifdef ARGPROC_DEBUG
9765 PerlIO_printf(Perl_debug_log, "%s\n", command);
9767 sprintf(pidstring, "%08X", pid);
9768 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9769 pidstr.dsc$a_pointer = pidstring;
9770 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9771 lib$set_symbol(&pidsymbol, &pidstr);
9775 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9778 /* OS-specific initialization at image activation (not thread startup) */
9779 /* Older VAXC header files lack these constants */
9780 #ifndef JPI$_RIGHTS_SIZE
9781 # define JPI$_RIGHTS_SIZE 817
9783 #ifndef KGB$M_SUBSYSTEM
9784 # define KGB$M_SUBSYSTEM 0x8
9787 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9789 /*{{{void vms_image_init(int *, char ***)*/
9791 vms_image_init(int *argcp, char ***argvp)
9794 char eqv[LNM$C_NAMLENGTH+1] = "";
9795 unsigned int len, tabct = 8, tabidx = 0;
9796 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9797 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9798 unsigned short int dummy, rlen;
9799 struct dsc$descriptor_s **tabvec;
9800 #if defined(PERL_IMPLICIT_CONTEXT)
9803 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
9804 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
9805 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9808 #ifdef KILL_BY_SIGPRC
9809 Perl_csighandler_init();
9812 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9813 /* This was moved from the pre-image init handler because on threaded */
9814 /* Perl it was always returning 0 for the default value. */
9815 status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9818 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9821 initial = decc$feature_get_value(s, 4);
9823 /* initial is: 0 if nothing has set the feature */
9824 /* -1 if initialized to default */
9825 /* 1 if set by logical name */
9826 /* 2 if set by decc$feature_set_value */
9827 decc_disable_posix_root = decc$feature_get_value(s, 1);
9829 /* If the value is not valid, force the feature off */
9830 if (decc_disable_posix_root < 0) {
9831 decc$feature_set_value(s, 1, 1);
9832 decc_disable_posix_root = 1;
9836 /* Nothing has asked for it explicitly, so use our own default. */
9837 decc_disable_posix_root = 1;
9838 decc$feature_set_value(s, 1, 1);
9844 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9845 _ckvmssts_noperl(iosb[0]);
9846 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9847 if (iprv[i]) { /* Running image installed with privs? */
9848 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
9853 /* Rights identifiers might trigger tainting as well. */
9854 if (!will_taint && (rlen || rsz)) {
9855 while (rlen < rsz) {
9856 /* We didn't get all the identifiers on the first pass. Allocate a
9857 * buffer much larger than $GETJPI wants (rsz is size in bytes that
9858 * were needed to hold all identifiers at time of last call; we'll
9859 * allocate that many unsigned long ints), and go back and get 'em.
9860 * If it gave us less than it wanted to despite ample buffer space,
9861 * something's broken. Is your system missing a system identifier?
9863 if (rsz <= jpilist[1].buflen) {
9864 /* Perl_croak accvios when used this early in startup. */
9865 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9866 rsz, (unsigned long) jpilist[1].buflen,
9867 "Check your rights database for corruption.\n");
9870 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9871 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9872 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9873 jpilist[1].buflen = rsz * sizeof(unsigned long int);
9874 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9875 _ckvmssts_noperl(iosb[0]);
9877 mask = jpilist[1].bufadr;
9878 /* Check attribute flags for each identifier (2nd longword); protected
9879 * subsystem identifiers trigger tainting.
9881 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9882 if (mask[i] & KGB$M_SUBSYSTEM) {
9887 if (mask != rlst) PerlMem_free(mask);
9890 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9891 * logical, some versions of the CRTL will add a phanthom /000000/
9892 * directory. This needs to be removed.
9894 if (decc_filename_unix_report) {
9897 ulen = strlen(argvp[0][0]);
9899 zeros = strstr(argvp[0][0], "/000000/");
9900 if (zeros != NULL) {
9902 mlen = ulen - (zeros - argvp[0][0]) - 7;
9903 memmove(zeros, &zeros[7], mlen);
9905 argvp[0][0][ulen] = '\0';
9908 /* It also may have a trailing dot that needs to be removed otherwise
9909 * it will be converted to VMS mode incorrectly.
9912 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9913 argvp[0][0][ulen] = '\0';
9916 /* We need to use this hack to tell Perl it should run with tainting,
9917 * since its tainting flag may be part of the PL_curinterp struct, which
9918 * hasn't been allocated when vms_image_init() is called.
9921 char **newargv, **oldargv;
9923 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9924 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9925 newargv[0] = oldargv[0];
9926 newargv[1] = PerlMem_malloc(3 * sizeof(char));
9927 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9928 strcpy(newargv[1], "-T");
9929 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9931 newargv[*argcp] = NULL;
9932 /* We orphan the old argv, since we don't know where it's come from,
9933 * so we don't know how to free it.
9937 else { /* Did user explicitly request tainting? */
9939 char *cp, **av = *argvp;
9940 for (i = 1; i < *argcp; i++) {
9941 if (*av[i] != '-') break;
9942 for (cp = av[i]+1; *cp; cp++) {
9943 if (*cp == 'T') { will_taint = 1; break; }
9944 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9945 strchr("DFIiMmx",*cp)) break;
9947 if (will_taint) break;
9952 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9955 tabvec = (struct dsc$descriptor_s **)
9956 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9957 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9959 else if (tabidx >= tabct) {
9961 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9962 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9964 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9965 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9966 tabvec[tabidx]->dsc$w_length = 0;
9967 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9968 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9969 tabvec[tabidx]->dsc$a_pointer = NULL;
9970 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9972 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9974 getredirection(argcp,argvp);
9975 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9977 # include <reentrancy.h>
9978 decc$set_reentrancy(C$C_MULTITHREAD);
9987 * Trim Unix-style prefix off filespec, so it looks like what a shell
9988 * glob expansion would return (i.e. from specified prefix on, not
9989 * full path). Note that returned filespec is Unix-style, regardless
9990 * of whether input filespec was VMS-style or Unix-style.
9992 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9993 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9994 * vector of options; at present, only bit 0 is used, and if set tells
9995 * trim unixpath to try the current default directory as a prefix when
9996 * presented with a possibly ambiguous ... wildcard.
9998 * Returns !=0 on success, with trimmed filespec replacing contents of
9999 * fspec, and 0 on failure, with contents of fpsec unchanged.
10001 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
10003 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
10005 char *unixified, *unixwild,
10006 *template, *base, *end, *cp1, *cp2;
10007 register int tmplen, reslen = 0, dirs = 0;
10009 if (!wildspec || !fspec) return 0;
10011 unixwild = PerlMem_malloc(VMS_MAXRSS);
10012 if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10013 template = unixwild;
10014 if (strpbrk(wildspec,"]>:") != NULL) {
10015 if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
10016 PerlMem_free(unixwild);
10021 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
10022 unixwild[VMS_MAXRSS-1] = 0;
10024 unixified = PerlMem_malloc(VMS_MAXRSS);
10025 if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10026 if (strpbrk(fspec,"]>:") != NULL) {
10027 if (int_tounixspec(fspec, unixified, NULL) == NULL) {
10028 PerlMem_free(unixwild);
10029 PerlMem_free(unixified);
10032 else base = unixified;
10033 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
10034 * check to see that final result fits into (isn't longer than) fspec */
10035 reslen = strlen(fspec);
10039 /* No prefix or absolute path on wildcard, so nothing to remove */
10040 if (!*template || *template == '/') {
10041 PerlMem_free(unixwild);
10042 if (base == fspec) {
10043 PerlMem_free(unixified);
10046 tmplen = strlen(unixified);
10047 if (tmplen > reslen) {
10048 PerlMem_free(unixified);
10049 return 0; /* not enough space */
10051 /* Copy unixified resultant, including trailing NUL */
10052 memmove(fspec,unixified,tmplen+1);
10053 PerlMem_free(unixified);
10057 for (end = base; *end; end++) ; /* Find end of resultant filespec */
10058 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
10059 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
10060 for (cp1 = end ;cp1 >= base; cp1--)
10061 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
10063 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
10064 PerlMem_free(unixified);
10065 PerlMem_free(unixwild);
10070 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
10071 int ells = 1, totells, segdirs, match;
10072 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
10073 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10075 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
10077 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
10078 tpl = PerlMem_malloc(VMS_MAXRSS);
10079 if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10080 if (ellipsis == template && opts & 1) {
10081 /* Template begins with an ellipsis. Since we can't tell how many
10082 * directory names at the front of the resultant to keep for an
10083 * arbitrary starting point, we arbitrarily choose the current
10084 * default directory as a starting point. If it's there as a prefix,
10085 * clip it off. If not, fall through and act as if the leading
10086 * ellipsis weren't there (i.e. return shortest possible path that
10087 * could match template).
10089 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
10091 PerlMem_free(unixified);
10092 PerlMem_free(unixwild);
10095 if (!decc_efs_case_preserve) {
10096 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10097 if (_tolower(*cp1) != _tolower(*cp2)) break;
10099 segdirs = dirs - totells; /* Min # of dirs we must have left */
10100 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
10101 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
10102 memmove(fspec,cp2+1,end - cp2);
10104 PerlMem_free(unixified);
10105 PerlMem_free(unixwild);
10109 /* First off, back up over constant elements at end of path */
10111 for (front = end ; front >= base; front--)
10112 if (*front == '/' && !dirs--) { front++; break; }
10114 lcres = PerlMem_malloc(VMS_MAXRSS);
10115 if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10116 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
10118 if (!decc_efs_case_preserve) {
10119 *cp2 = _tolower(*cp1); /* Make lc copy for match */
10127 PerlMem_free(unixified);
10128 PerlMem_free(unixwild);
10129 PerlMem_free(lcres);
10130 return 0; /* Path too long. */
10133 *cp2 = '\0'; /* Pick up with memcpy later */
10134 lcfront = lcres + (front - base);
10135 /* Now skip over each ellipsis and try to match the path in front of it. */
10137 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
10138 if (*(cp1) == '.' && *(cp1+1) == '.' &&
10139 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
10140 if (cp1 < template) break; /* template started with an ellipsis */
10141 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
10142 ellipsis = cp1; continue;
10144 wilddsc.dsc$a_pointer = tpl;
10145 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
10147 for (segdirs = 0, cp2 = tpl;
10148 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
10150 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
10152 if (!decc_efs_case_preserve) {
10153 *cp2 = _tolower(*cp1); /* else lowercase for match */
10156 *cp2 = *cp1; /* else preserve case for match */
10159 if (*cp2 == '/') segdirs++;
10161 if (cp1 != ellipsis - 1) {
10163 PerlMem_free(unixified);
10164 PerlMem_free(unixwild);
10165 PerlMem_free(lcres);
10166 return 0; /* Path too long */
10168 /* Back up at least as many dirs as in template before matching */
10169 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10170 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10171 for (match = 0; cp1 > lcres;) {
10172 resdsc.dsc$a_pointer = cp1;
10173 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10175 if (match == 1) lcfront = cp1;
10177 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10181 PerlMem_free(unixified);
10182 PerlMem_free(unixwild);
10183 PerlMem_free(lcres);
10184 return 0; /* Can't find prefix ??? */
10186 if (match > 1 && opts & 1) {
10187 /* This ... wildcard could cover more than one set of dirs (i.e.
10188 * a set of similar dir names is repeated). If the template
10189 * contains more than 1 ..., upstream elements could resolve the
10190 * ambiguity, but it's not worth a full backtracking setup here.
10191 * As a quick heuristic, clip off the current default directory
10192 * if it's present to find the trimmed spec, else use the
10193 * shortest string that this ... could cover.
10195 char def[NAM$C_MAXRSS+1], *st;
10197 if (getcwd(def, sizeof def,0) == NULL) {
10198 PerlMem_free(unixified);
10199 PerlMem_free(unixwild);
10200 PerlMem_free(lcres);
10204 if (!decc_efs_case_preserve) {
10205 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10206 if (_tolower(*cp1) != _tolower(*cp2)) break;
10208 segdirs = dirs - totells; /* Min # of dirs we must have left */
10209 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10210 if (*cp1 == '\0' && *cp2 == '/') {
10211 memmove(fspec,cp2+1,end - cp2);
10213 PerlMem_free(unixified);
10214 PerlMem_free(unixwild);
10215 PerlMem_free(lcres);
10218 /* Nope -- stick with lcfront from above and keep going. */
10221 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10223 PerlMem_free(unixified);
10224 PerlMem_free(unixwild);
10225 PerlMem_free(lcres);
10227 ellipsis = nextell;
10230 } /* end of trim_unixpath() */
10235 * VMS readdir() routines.
10236 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10238 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
10239 * Minor modifications to original routines.
10242 /* readdir may have been redefined by reentr.h, so make sure we get
10243 * the local version for what we do here.
10248 #if !defined(PERL_IMPLICIT_CONTEXT)
10249 # define readdir Perl_readdir
10251 # define readdir(a) Perl_readdir(aTHX_ a)
10254 /* Number of elements in vms_versions array */
10255 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
10258 * Open a directory, return a handle for later use.
10260 /*{{{ DIR *opendir(char*name) */
10262 Perl_opendir(pTHX_ const char *name)
10268 Newx(dir, VMS_MAXRSS, char);
10269 if (int_tovmspath(name, dir, NULL) == NULL) {
10273 /* Check access before stat; otherwise stat does not
10274 * accurately report whether it's a directory.
10276 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10277 /* cando_by_name has already set errno */
10281 if (flex_stat(dir,&sb) == -1) return NULL;
10282 if (!S_ISDIR(sb.st_mode)) {
10284 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
10287 /* Get memory for the handle, and the pattern. */
10289 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10291 /* Fill in the fields; mainly playing with the descriptor. */
10292 sprintf(dd->pattern, "%s*.*",dir);
10297 /* By saying we always want the result of readdir() in unix format, we
10298 * are really saying we want all the escapes removed. Otherwise the caller,
10299 * having no way to know whether it's already in VMS format, might send it
10300 * through tovmsspec again, thus double escaping.
10302 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10303 dd->pat.dsc$a_pointer = dd->pattern;
10304 dd->pat.dsc$w_length = strlen(dd->pattern);
10305 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10306 dd->pat.dsc$b_class = DSC$K_CLASS_S;
10307 #if defined(USE_ITHREADS)
10308 Newx(dd->mutex,1,perl_mutex);
10309 MUTEX_INIT( (perl_mutex *) dd->mutex );
10315 } /* end of opendir() */
10319 * Set the flag to indicate we want versions or not.
10321 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10323 vmsreaddirversions(DIR *dd, int flag)
10326 dd->flags |= PERL_VMSDIR_M_VERSIONS;
10328 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10333 * Free up an opened directory.
10335 /*{{{ void closedir(DIR *dd)*/
10337 Perl_closedir(DIR *dd)
10341 sts = lib$find_file_end(&dd->context);
10342 Safefree(dd->pattern);
10343 #if defined(USE_ITHREADS)
10344 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10345 Safefree(dd->mutex);
10352 * Collect all the version numbers for the current file.
10355 collectversions(pTHX_ DIR *dd)
10357 struct dsc$descriptor_s pat;
10358 struct dsc$descriptor_s res;
10360 char *p, *text, *buff;
10362 unsigned long context, tmpsts;
10364 /* Convenient shorthand. */
10367 /* Add the version wildcard, ignoring the "*.*" put on before */
10368 i = strlen(dd->pattern);
10369 Newx(text,i + e->d_namlen + 3,char);
10370 strcpy(text, dd->pattern);
10371 sprintf(&text[i - 3], "%s;*", e->d_name);
10373 /* Set up the pattern descriptor. */
10374 pat.dsc$a_pointer = text;
10375 pat.dsc$w_length = i + e->d_namlen - 1;
10376 pat.dsc$b_dtype = DSC$K_DTYPE_T;
10377 pat.dsc$b_class = DSC$K_CLASS_S;
10379 /* Set up result descriptor. */
10380 Newx(buff, VMS_MAXRSS, char);
10381 res.dsc$a_pointer = buff;
10382 res.dsc$w_length = VMS_MAXRSS - 1;
10383 res.dsc$b_dtype = DSC$K_DTYPE_T;
10384 res.dsc$b_class = DSC$K_CLASS_S;
10386 /* Read files, collecting versions. */
10387 for (context = 0, e->vms_verscount = 0;
10388 e->vms_verscount < VERSIZE(e);
10389 e->vms_verscount++) {
10390 unsigned long rsts;
10391 unsigned long flags = 0;
10393 #ifdef VMS_LONGNAME_SUPPORT
10394 flags = LIB$M_FIL_LONG_NAMES;
10396 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10397 if (tmpsts == RMS$_NMF || context == 0) break;
10399 buff[VMS_MAXRSS - 1] = '\0';
10400 if ((p = strchr(buff, ';')))
10401 e->vms_versions[e->vms_verscount] = atoi(p + 1);
10403 e->vms_versions[e->vms_verscount] = -1;
10406 _ckvmssts(lib$find_file_end(&context));
10410 } /* end of collectversions() */
10413 * Read the next entry from the directory.
10415 /*{{{ struct dirent *readdir(DIR *dd)*/
10417 Perl_readdir(pTHX_ DIR *dd)
10419 struct dsc$descriptor_s res;
10421 unsigned long int tmpsts;
10422 unsigned long rsts;
10423 unsigned long flags = 0;
10424 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10425 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10427 /* Set up result descriptor, and get next file. */
10428 Newx(buff, VMS_MAXRSS, char);
10429 res.dsc$a_pointer = buff;
10430 res.dsc$w_length = VMS_MAXRSS - 1;
10431 res.dsc$b_dtype = DSC$K_DTYPE_T;
10432 res.dsc$b_class = DSC$K_CLASS_S;
10434 #ifdef VMS_LONGNAME_SUPPORT
10435 flags = LIB$M_FIL_LONG_NAMES;
10438 tmpsts = lib$find_file
10439 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10440 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
10441 if (!(tmpsts & 1)) {
10442 set_vaxc_errno(tmpsts);
10445 set_errno(EACCES); break;
10447 set_errno(ENODEV); break;
10449 set_errno(ENOTDIR); break;
10450 case RMS$_FNF: case RMS$_DNF:
10451 set_errno(ENOENT); break;
10453 set_errno(EVMSERR);
10459 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10460 buff[res.dsc$w_length] = '\0';
10461 p = buff + res.dsc$w_length;
10462 while (--p >= buff) if (!isspace(*p)) break;
10464 if (!decc_efs_case_preserve) {
10465 for (p = buff; *p; p++) *p = _tolower(*p);
10468 /* Skip any directory component and just copy the name. */
10469 sts = vms_split_path
10484 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10486 /* In Unix report mode, remove the ".dir;1" from the name */
10487 /* if it is a real directory. */
10488 if (decc_filename_unix_report || decc_efs_charset) {
10489 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10493 ret_sts = flex_lstat(buff, &statbuf);
10494 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10501 /* Drop NULL extensions on UNIX file specification */
10502 if ((e_len == 1) && decc_readdir_dropdotnotype) {
10508 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10509 dd->entry.d_name[n_len + e_len] = '\0';
10510 dd->entry.d_namlen = strlen(dd->entry.d_name);
10512 /* Convert the filename to UNIX format if needed */
10513 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10515 /* Translate the encoded characters. */
10516 /* Fixme: Unicode handling could result in embedded 0 characters */
10517 if (strchr(dd->entry.d_name, '^') != NULL) {
10518 char new_name[256];
10520 p = dd->entry.d_name;
10523 int inchars_read, outchars_added;
10524 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10526 q += outchars_added;
10528 /* if outchars_added > 1, then this is a wide file specification */
10529 /* Wide file specifications need to be passed in Perl */
10530 /* counted strings apparently with a Unicode flag */
10533 strcpy(dd->entry.d_name, new_name);
10534 dd->entry.d_namlen = strlen(dd->entry.d_name);
10538 dd->entry.vms_verscount = 0;
10539 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10543 } /* end of readdir() */
10547 * Read the next entry from the directory -- thread-safe version.
10549 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10551 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10555 MUTEX_LOCK( (perl_mutex *) dd->mutex );
10557 entry = readdir(dd);
10559 retval = ( *result == NULL ? errno : 0 );
10561 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10565 } /* end of readdir_r() */
10569 * Return something that can be used in a seekdir later.
10571 /*{{{ long telldir(DIR *dd)*/
10573 Perl_telldir(DIR *dd)
10580 * Return to a spot where we used to be. Brute force.
10582 /*{{{ void seekdir(DIR *dd,long count)*/
10584 Perl_seekdir(pTHX_ DIR *dd, long count)
10588 /* If we haven't done anything yet... */
10589 if (dd->count == 0)
10592 /* Remember some state, and clear it. */
10593 old_flags = dd->flags;
10594 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10595 _ckvmssts(lib$find_file_end(&dd->context));
10598 /* The increment is in readdir(). */
10599 for (dd->count = 0; dd->count < count; )
10602 dd->flags = old_flags;
10604 } /* end of seekdir() */
10607 /* VMS subprocess management
10609 * my_vfork() - just a vfork(), after setting a flag to record that
10610 * the current script is trying a Unix-style fork/exec.
10612 * vms_do_aexec() and vms_do_exec() are called in response to the
10613 * perl 'exec' function. If this follows a vfork call, then they
10614 * call out the regular perl routines in doio.c which do an
10615 * execvp (for those who really want to try this under VMS).
10616 * Otherwise, they do exactly what the perl docs say exec should
10617 * do - terminate the current script and invoke a new command
10618 * (See below for notes on command syntax.)
10620 * do_aspawn() and do_spawn() implement the VMS side of the perl
10621 * 'system' function.
10623 * Note on command arguments to perl 'exec' and 'system': When handled
10624 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10625 * are concatenated to form a DCL command string. If the first non-numeric
10626 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10627 * the command string is handed off to DCL directly. Otherwise,
10628 * the first token of the command is taken as the filespec of an image
10629 * to run. The filespec is expanded using a default type of '.EXE' and
10630 * the process defaults for device, directory, etc., and if found, the resultant
10631 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10632 * the command string as parameters. This is perhaps a bit complicated,
10633 * but I hope it will form a happy medium between what VMS folks expect
10634 * from lib$spawn and what Unix folks expect from exec.
10637 static int vfork_called;
10639 /*{{{int my_vfork()*/
10650 vms_execfree(struct dsc$descriptor_s *vmscmd)
10653 if (vmscmd->dsc$a_pointer) {
10654 PerlMem_free(vmscmd->dsc$a_pointer);
10656 PerlMem_free(vmscmd);
10661 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10663 char *junk, *tmps = NULL;
10664 register size_t cmdlen = 0;
10671 tmps = SvPV(really,rlen);
10673 cmdlen += rlen + 1;
10678 for (idx++; idx <= sp; idx++) {
10680 junk = SvPVx(*idx,rlen);
10681 cmdlen += rlen ? rlen + 1 : 0;
10684 Newx(PL_Cmd, cmdlen+1, char);
10686 if (tmps && *tmps) {
10687 strcpy(PL_Cmd,tmps);
10690 else *PL_Cmd = '\0';
10691 while (++mark <= sp) {
10693 char *s = SvPVx(*mark,n_a);
10695 if (*PL_Cmd) strcat(PL_Cmd," ");
10701 } /* end of setup_argstr() */
10704 static unsigned long int
10705 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10706 struct dsc$descriptor_s **pvmscmd)
10710 char image_name[NAM$C_MAXRSS+1];
10711 char image_argv[NAM$C_MAXRSS+1];
10712 $DESCRIPTOR(defdsc,".EXE");
10713 $DESCRIPTOR(defdsc2,".");
10714 struct dsc$descriptor_s resdsc;
10715 struct dsc$descriptor_s *vmscmd;
10716 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10717 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10718 register char *s, *rest, *cp, *wordbreak;
10721 register int isdcl;
10723 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10724 if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10726 /* vmsspec is a DCL command buffer, not just a filename */
10727 vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10728 if (vmsspec == NULL)
10729 _ckvmssts_noperl(SS$_INSFMEM);
10731 resspec = PerlMem_malloc(VMS_MAXRSS);
10732 if (resspec == NULL)
10733 _ckvmssts_noperl(SS$_INSFMEM);
10735 /* Make a copy for modification */
10736 cmdlen = strlen(incmd);
10737 cmd = PerlMem_malloc(cmdlen+1);
10738 if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10739 strncpy(cmd, incmd, cmdlen);
10744 resdsc.dsc$a_pointer = resspec;
10745 resdsc.dsc$b_dtype = DSC$K_DTYPE_T;
10746 resdsc.dsc$b_class = DSC$K_CLASS_S;
10747 resdsc.dsc$w_length = VMS_MAXRSS - 1;
10749 vmscmd->dsc$a_pointer = NULL;
10750 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
10751 vmscmd->dsc$b_class = DSC$K_CLASS_S;
10752 vmscmd->dsc$w_length = 0;
10753 if (pvmscmd) *pvmscmd = vmscmd;
10755 if (suggest_quote) *suggest_quote = 0;
10757 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10759 PerlMem_free(vmsspec);
10760 PerlMem_free(resspec);
10761 return CLI$_BUFOVF; /* continuation lines currently unsupported */
10766 while (*s && isspace(*s)) s++;
10768 if (*s == '@' || *s == '$') {
10769 vmsspec[0] = *s; rest = s + 1;
10770 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10772 else { cp = vmsspec; rest = s; }
10773 if (*rest == '.' || *rest == '/') {
10775 for (cp2 = resspec;
10776 *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10777 rest++, cp2++) *cp2 = *rest;
10779 if (int_tovmsspec(resspec, cp, 0, NULL)) {
10782 /* When a UNIX spec with no file type is translated to VMS, */
10783 /* A trailing '.' is appended under ODS-5 rules. */
10784 /* Here we do not want that trailing "." as it prevents */
10785 /* Looking for a implied ".exe" type. */
10786 if (decc_efs_charset) {
10788 i = strlen(vmsspec);
10789 if (vmsspec[i-1] == '.') {
10790 vmsspec[i-1] = '\0';
10795 for (cp2 = vmsspec + strlen(vmsspec);
10796 *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10797 rest++, cp2++) *cp2 = *rest;
10802 /* Intuit whether verb (first word of cmd) is a DCL command:
10803 * - if first nonspace char is '@', it's a DCL indirection
10805 * - if verb contains a filespec separator, it's not a DCL command
10806 * - if it doesn't, caller tells us whether to default to a DCL
10807 * command, or to a local image unless told it's DCL (by leading '$')
10811 if (suggest_quote) *suggest_quote = 1;
10813 register char *filespec = strpbrk(s,":<[.;");
10814 rest = wordbreak = strpbrk(s," \"\t/");
10815 if (!wordbreak) wordbreak = s + strlen(s);
10816 if (*s == '$') check_img = 0;
10817 if (filespec && (filespec < wordbreak)) isdcl = 0;
10818 else isdcl = !check_img;
10823 imgdsc.dsc$a_pointer = s;
10824 imgdsc.dsc$w_length = wordbreak - s;
10825 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10827 _ckvmssts_noperl(lib$find_file_end(&cxt));
10828 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10829 if (!(retsts & 1) && *s == '$') {
10830 _ckvmssts_noperl(lib$find_file_end(&cxt));
10831 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10832 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10834 _ckvmssts_noperl(lib$find_file_end(&cxt));
10835 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10839 _ckvmssts_noperl(lib$find_file_end(&cxt));
10844 while (*s && !isspace(*s)) s++;
10847 /* check that it's really not DCL with no file extension */
10848 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10850 char b[256] = {0,0,0,0};
10851 read(fileno(fp), b, 256);
10852 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10856 /* Check for script */
10858 if ((b[0] == '#') && (b[1] == '!'))
10860 #ifdef ALTERNATE_SHEBANG
10862 shebang_len = strlen(ALTERNATE_SHEBANG);
10863 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10865 perlstr = strstr("perl",b);
10866 if (perlstr == NULL)
10874 if (shebang_len > 0) {
10877 char tmpspec[NAM$C_MAXRSS + 1];
10880 /* Image is following after white space */
10881 /*--------------------------------------*/
10882 while (isprint(b[i]) && isspace(b[i]))
10886 while (isprint(b[i]) && !isspace(b[i])) {
10887 tmpspec[j++] = b[i++];
10888 if (j >= NAM$C_MAXRSS)
10893 /* There may be some default parameters to the image */
10894 /*---------------------------------------------------*/
10896 while (isprint(b[i])) {
10897 image_argv[j++] = b[i++];
10898 if (j >= NAM$C_MAXRSS)
10901 while ((j > 0) && !isprint(image_argv[j-1]))
10905 /* It will need to be converted to VMS format and validated */
10906 if (tmpspec[0] != '\0') {
10909 /* Try to find the exact program requested to be run */
10910 /*---------------------------------------------------*/
10911 iname = int_rmsexpand
10912 (tmpspec, image_name, ".exe",
10913 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10914 if (iname != NULL) {
10915 if (cando_by_name_int
10916 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10917 /* MCR prefix needed */
10921 /* Try again with a null type */
10922 /*----------------------------*/
10923 iname = int_rmsexpand
10924 (tmpspec, image_name, ".",
10925 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10926 if (iname != NULL) {
10927 if (cando_by_name_int
10928 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10929 /* MCR prefix needed */
10935 /* Did we find the image to run the script? */
10936 /*------------------------------------------*/
10940 /* Assume DCL or foreign command exists */
10941 /*--------------------------------------*/
10942 tchr = strrchr(tmpspec, '/');
10943 if (tchr != NULL) {
10949 strcpy(image_name, tchr);
10957 if (check_img && isdcl) {
10959 PerlMem_free(resspec);
10960 PerlMem_free(vmsspec);
10964 if (cando_by_name(S_IXUSR,0,resspec)) {
10965 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10966 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10968 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10969 if (image_name[0] != 0) {
10970 strcat(vmscmd->dsc$a_pointer, image_name);
10971 strcat(vmscmd->dsc$a_pointer, " ");
10973 } else if (image_name[0] != 0) {
10974 strcpy(vmscmd->dsc$a_pointer, image_name);
10975 strcat(vmscmd->dsc$a_pointer, " ");
10977 strcpy(vmscmd->dsc$a_pointer,"@");
10979 if (suggest_quote) *suggest_quote = 1;
10981 /* If there is an image name, use original command */
10982 if (image_name[0] == 0)
10983 strcat(vmscmd->dsc$a_pointer,resspec);
10986 while (*rest && isspace(*rest)) rest++;
10989 if (image_argv[0] != 0) {
10990 strcat(vmscmd->dsc$a_pointer,image_argv);
10991 strcat(vmscmd->dsc$a_pointer, " ");
10997 rest_len = strlen(rest);
10998 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10999 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
11000 strcat(vmscmd->dsc$a_pointer,rest);
11002 retsts = CLI$_BUFOVF;
11004 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
11006 PerlMem_free(vmsspec);
11007 PerlMem_free(resspec);
11008 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
11014 /* It's either a DCL command or we couldn't find a suitable image */
11015 vmscmd->dsc$w_length = strlen(cmd);
11017 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
11018 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
11019 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
11022 PerlMem_free(resspec);
11023 PerlMem_free(vmsspec);
11025 /* check if it's a symbol (for quoting purposes) */
11026 if (suggest_quote && !*suggest_quote) {
11028 char equiv[LNM$C_NAMLENGTH];
11029 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11030 eqvdsc.dsc$a_pointer = equiv;
11032 iss = lib$get_symbol(vmscmd,&eqvdsc);
11033 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
11035 if (!(retsts & 1)) {
11036 /* just hand off status values likely to be due to user error */
11037 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
11038 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
11039 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
11040 else { _ckvmssts_noperl(retsts); }
11043 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
11045 } /* end of setup_cmddsc() */
11048 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
11050 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
11056 if (vfork_called) { /* this follows a vfork - act Unixish */
11058 if (vfork_called < 0) {
11059 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11062 else return do_aexec(really,mark,sp);
11064 /* no vfork - act VMSish */
11065 cmd = setup_argstr(aTHX_ really,mark,sp);
11066 exec_sts = vms_do_exec(cmd);
11067 Safefree(cmd); /* Clean up from setup_argstr() */
11072 } /* end of vms_do_aexec() */
11075 /* {{{bool vms_do_exec(char *cmd) */
11077 Perl_vms_do_exec(pTHX_ const char *cmd)
11079 struct dsc$descriptor_s *vmscmd;
11081 if (vfork_called) { /* this follows a vfork - act Unixish */
11083 if (vfork_called < 0) {
11084 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11087 else return do_exec(cmd);
11090 { /* no vfork - act VMSish */
11091 unsigned long int retsts;
11094 TAINT_PROPER("exec");
11095 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
11096 retsts = lib$do_command(vmscmd);
11099 case RMS$_FNF: case RMS$_DNF:
11100 set_errno(ENOENT); break;
11102 set_errno(ENOTDIR); break;
11104 set_errno(ENODEV); break;
11106 set_errno(EACCES); break;
11108 set_errno(EINVAL); break;
11109 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11110 set_errno(E2BIG); break;
11111 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11112 _ckvmssts_noperl(retsts); /* fall through */
11113 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11114 set_errno(EVMSERR);
11116 set_vaxc_errno(retsts);
11117 if (ckWARN(WARN_EXEC)) {
11118 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
11119 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
11121 vms_execfree(vmscmd);
11126 } /* end of vms_do_exec() */
11129 int do_spawn2(pTHX_ const char *, int);
11132 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11134 unsigned long int sts;
11140 /* We'll copy the (undocumented?) Win32 behavior and allow a
11141 * numeric first argument. But the only value we'll support
11142 * through do_aspawn is a value of 1, which means spawn without
11143 * waiting for completion -- other values are ignored.
11145 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11147 flags = SvIVx(*mark);
11150 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
11151 flags = CLI$M_NOWAIT;
11155 cmd = setup_argstr(aTHX_ really, mark, sp);
11156 sts = do_spawn2(aTHX_ cmd, flags);
11157 /* pp_sys will clean up cmd */
11161 } /* end of do_aspawn() */
11165 /* {{{int do_spawn(char* cmd) */
11167 Perl_do_spawn(pTHX_ char* cmd)
11169 PERL_ARGS_ASSERT_DO_SPAWN;
11171 return do_spawn2(aTHX_ cmd, 0);
11175 /* {{{int do_spawn_nowait(char* cmd) */
11177 Perl_do_spawn_nowait(pTHX_ char* cmd)
11179 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11181 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11185 /* {{{int do_spawn2(char *cmd) */
11187 do_spawn2(pTHX_ const char *cmd, int flags)
11189 unsigned long int sts, substs;
11191 /* The caller of this routine expects to Safefree(PL_Cmd) */
11192 Newx(PL_Cmd,10,char);
11195 TAINT_PROPER("spawn");
11196 if (!cmd || !*cmd) {
11197 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11200 case RMS$_FNF: case RMS$_DNF:
11201 set_errno(ENOENT); break;
11203 set_errno(ENOTDIR); break;
11205 set_errno(ENODEV); break;
11207 set_errno(EACCES); break;
11209 set_errno(EINVAL); break;
11210 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11211 set_errno(E2BIG); break;
11212 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11213 _ckvmssts_noperl(sts); /* fall through */
11214 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11215 set_errno(EVMSERR);
11217 set_vaxc_errno(sts);
11218 if (ckWARN(WARN_EXEC)) {
11219 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11228 if (flags & CLI$M_NOWAIT)
11231 strcpy(mode, "nW");
11233 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11236 /* sts will be the pid in the nowait case */
11239 } /* end of do_spawn2() */
11243 static unsigned int *sockflags, sockflagsize;
11246 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11247 * routines found in some versions of the CRTL can't deal with sockets.
11248 * We don't shim the other file open routines since a socket isn't
11249 * likely to be opened by a name.
11251 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11252 FILE *my_fdopen(int fd, const char *mode)
11254 FILE *fp = fdopen(fd, mode);
11257 unsigned int fdoff = fd / sizeof(unsigned int);
11258 Stat_t sbuf; /* native stat; we don't need flex_stat */
11259 if (!sockflagsize || fdoff > sockflagsize) {
11260 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
11261 else Newx (sockflags,fdoff+2,unsigned int);
11262 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11263 sockflagsize = fdoff + 2;
11265 if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11266 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11275 * Clear the corresponding bit when the (possibly) socket stream is closed.
11276 * There still a small hole: we miss an implicit close which might occur
11277 * via freopen(). >> Todo
11279 /*{{{ int my_fclose(FILE *fp)*/
11280 int my_fclose(FILE *fp) {
11282 unsigned int fd = fileno(fp);
11283 unsigned int fdoff = fd / sizeof(unsigned int);
11285 if (sockflagsize && fdoff < sockflagsize)
11286 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11294 * A simple fwrite replacement which outputs itmsz*nitm chars without
11295 * introducing record boundaries every itmsz chars.
11296 * We are using fputs, which depends on a terminating null. We may
11297 * well be writing binary data, so we need to accommodate not only
11298 * data with nulls sprinkled in the middle but also data with no null
11301 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11303 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11305 register char *cp, *end, *cpd;
11307 register unsigned int fd = fileno(dest);
11308 register unsigned int fdoff = fd / sizeof(unsigned int);
11310 int bufsize = itmsz * nitm + 1;
11312 if (fdoff < sockflagsize &&
11313 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11314 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11318 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11319 memcpy( data, src, itmsz*nitm );
11320 data[itmsz*nitm] = '\0';
11322 end = data + itmsz * nitm;
11323 retval = (int) nitm; /* on success return # items written */
11326 while (cpd <= end) {
11327 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11328 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11330 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11334 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11337 } /* end of my_fwrite() */
11340 /*{{{ int my_flush(FILE *fp)*/
11342 Perl_my_flush(pTHX_ FILE *fp)
11345 if ((res = fflush(fp)) == 0 && fp) {
11346 #ifdef VMS_DO_SOCKETS
11348 if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11350 res = fsync(fileno(fp));
11353 * If the flush succeeded but set end-of-file, we need to clear
11354 * the error because our caller may check ferror(). BTW, this
11355 * probably means we just flushed an empty file.
11357 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11363 /* fgetname() is not returning the correct file specifications when
11364 * decc_filename_unix_report mode is active. So we have to have it
11365 * aways return filenames in VMS mode and convert it ourselves.
11368 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11370 Perl_my_fgetname(FILE *fp, char * buf) {
11374 retname = fgetname(fp, buf, 1);
11376 /* If we are in VMS mode, then we are done */
11377 if (!decc_filename_unix_report || (retname == NULL)) {
11381 /* Convert this to Unix format */
11382 vms_name = PerlMem_malloc(VMS_MAXRSS + 1);
11383 strcpy(vms_name, retname);
11384 retname = int_tounixspec(vms_name, buf, NULL);
11385 PerlMem_free(vms_name);
11392 * Here are replacements for the following Unix routines in the VMS environment:
11393 * getpwuid Get information for a particular UIC or UID
11394 * getpwnam Get information for a named user
11395 * getpwent Get information for each user in the rights database
11396 * setpwent Reset search to the start of the rights database
11397 * endpwent Finish searching for users in the rights database
11399 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11400 * (defined in pwd.h), which contains the following fields:-
11402 * char *pw_name; Username (in lower case)
11403 * char *pw_passwd; Hashed password
11404 * unsigned int pw_uid; UIC
11405 * unsigned int pw_gid; UIC group number
11406 * char *pw_unixdir; Default device/directory (VMS-style)
11407 * char *pw_gecos; Owner name
11408 * char *pw_dir; Default device/directory (Unix-style)
11409 * char *pw_shell; Default CLI name (eg. DCL)
11411 * If the specified user does not exist, getpwuid and getpwnam return NULL.
11413 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11414 * not the UIC member number (eg. what's returned by getuid()),
11415 * getpwuid() can accept either as input (if uid is specified, the caller's
11416 * UIC group is used), though it won't recognise gid=0.
11418 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11419 * information about other users in your group or in other groups, respectively.
11420 * If the required privilege is not available, then these routines fill only
11421 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11424 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11427 /* sizes of various UAF record fields */
11428 #define UAI$S_USERNAME 12
11429 #define UAI$S_IDENT 31
11430 #define UAI$S_OWNER 31
11431 #define UAI$S_DEFDEV 31
11432 #define UAI$S_DEFDIR 63
11433 #define UAI$S_DEFCLI 31
11434 #define UAI$S_PWD 8
11436 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
11437 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11438 (uic).uic$v_group != UIC$K_WILD_GROUP)
11440 static char __empty[]= "";
11441 static struct passwd __passwd_empty=
11442 {(char *) __empty, (char *) __empty, 0, 0,
11443 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11444 static int contxt= 0;
11445 static struct passwd __pwdcache;
11446 static char __pw_namecache[UAI$S_IDENT+1];
11449 * This routine does most of the work extracting the user information.
11451 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11454 unsigned char length;
11455 char pw_gecos[UAI$S_OWNER+1];
11457 static union uicdef uic;
11459 unsigned char length;
11460 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11463 unsigned char length;
11464 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11467 unsigned char length;
11468 char pw_shell[UAI$S_DEFCLI+1];
11470 static char pw_passwd[UAI$S_PWD+1];
11472 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11473 struct dsc$descriptor_s name_desc;
11474 unsigned long int sts;
11476 static struct itmlst_3 itmlst[]= {
11477 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
11478 {sizeof(uic), UAI$_UIC, &uic, &luic},
11479 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
11480 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
11481 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
11482 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
11483 {0, 0, NULL, NULL}};
11485 name_desc.dsc$w_length= strlen(name);
11486 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11487 name_desc.dsc$b_class= DSC$K_CLASS_S;
11488 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11490 /* Note that sys$getuai returns many fields as counted strings. */
11491 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11492 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11493 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11495 else { _ckvmssts(sts); }
11496 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
11498 if ((int) owner.length < lowner) lowner= (int) owner.length;
11499 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11500 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11501 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11502 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11503 owner.pw_gecos[lowner]= '\0';
11504 defdev.pw_dir[ldefdev+ldefdir]= '\0';
11505 defcli.pw_shell[ldefcli]= '\0';
11506 if (valid_uic(uic)) {
11507 pwd->pw_uid= uic.uic$l_uic;
11508 pwd->pw_gid= uic.uic$v_group;
11511 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11512 pwd->pw_passwd= pw_passwd;
11513 pwd->pw_gecos= owner.pw_gecos;
11514 pwd->pw_dir= defdev.pw_dir;
11515 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11516 pwd->pw_shell= defcli.pw_shell;
11517 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11519 ldir= strlen(pwd->pw_unixdir) - 1;
11520 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11523 strcpy(pwd->pw_unixdir, pwd->pw_dir);
11524 if (!decc_efs_case_preserve)
11525 __mystrtolower(pwd->pw_unixdir);
11530 * Get information for a named user.
11532 /*{{{struct passwd *getpwnam(char *name)*/
11533 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11535 struct dsc$descriptor_s name_desc;
11537 unsigned long int status, sts;
11539 __pwdcache = __passwd_empty;
11540 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11541 /* We still may be able to determine pw_uid and pw_gid */
11542 name_desc.dsc$w_length= strlen(name);
11543 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11544 name_desc.dsc$b_class= DSC$K_CLASS_S;
11545 name_desc.dsc$a_pointer= (char *) name;
11546 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11547 __pwdcache.pw_uid= uic.uic$l_uic;
11548 __pwdcache.pw_gid= uic.uic$v_group;
11551 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11552 set_vaxc_errno(sts);
11553 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11556 else { _ckvmssts(sts); }
11559 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11560 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11561 __pwdcache.pw_name= __pw_namecache;
11562 return &__pwdcache;
11563 } /* end of my_getpwnam() */
11567 * Get information for a particular UIC or UID.
11568 * Called by my_getpwent with uid=-1 to list all users.
11570 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11571 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11573 const $DESCRIPTOR(name_desc,__pw_namecache);
11574 unsigned short lname;
11576 unsigned long int status;
11578 if (uid == (unsigned int) -1) {
11580 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11581 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11582 set_vaxc_errno(status);
11583 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11587 else { _ckvmssts(status); }
11588 } while (!valid_uic (uic));
11591 uic.uic$l_uic= uid;
11592 if (!uic.uic$v_group)
11593 uic.uic$v_group= PerlProc_getgid();
11594 if (valid_uic(uic))
11595 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11596 else status = SS$_IVIDENT;
11597 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11598 status == RMS$_PRV) {
11599 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11602 else { _ckvmssts(status); }
11604 __pw_namecache[lname]= '\0';
11605 __mystrtolower(__pw_namecache);
11607 __pwdcache = __passwd_empty;
11608 __pwdcache.pw_name = __pw_namecache;
11610 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11611 The identifier's value is usually the UIC, but it doesn't have to be,
11612 so if we can, we let fillpasswd update this. */
11613 __pwdcache.pw_uid = uic.uic$l_uic;
11614 __pwdcache.pw_gid = uic.uic$v_group;
11616 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11617 return &__pwdcache;
11619 } /* end of my_getpwuid() */
11623 * Get information for next user.
11625 /*{{{struct passwd *my_getpwent()*/
11626 struct passwd *Perl_my_getpwent(pTHX)
11628 return (my_getpwuid((unsigned int) -1));
11633 * Finish searching rights database for users.
11635 /*{{{void my_endpwent()*/
11636 void Perl_my_endpwent(pTHX)
11639 _ckvmssts(sys$finish_rdb(&contxt));
11645 #ifdef HOMEGROWN_POSIX_SIGNALS
11646 /* Signal handling routines, pulled into the core from POSIX.xs.
11648 * We need these for threads, so they've been rolled into the core,
11649 * rather than left in POSIX.xs.
11651 * (DRS, Oct 23, 1997)
11654 /* sigset_t is atomic under VMS, so these routines are easy */
11655 /*{{{int my_sigemptyset(sigset_t *) */
11656 int my_sigemptyset(sigset_t *set) {
11657 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11658 *set = 0; return 0;
11663 /*{{{int my_sigfillset(sigset_t *)*/
11664 int my_sigfillset(sigset_t *set) {
11666 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11667 for (i = 0; i < NSIG; i++) *set |= (1 << i);
11673 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11674 int my_sigaddset(sigset_t *set, int sig) {
11675 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11676 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11677 *set |= (1 << (sig - 1));
11683 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11684 int my_sigdelset(sigset_t *set, int sig) {
11685 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11686 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11687 *set &= ~(1 << (sig - 1));
11693 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11694 int my_sigismember(sigset_t *set, int sig) {
11695 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11696 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11697 return *set & (1 << (sig - 1));
11702 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11703 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11706 /* If set and oset are both null, then things are badly wrong. Bail out. */
11707 if ((oset == NULL) && (set == NULL)) {
11708 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11712 /* If set's null, then we're just handling a fetch. */
11714 tempmask = sigblock(0);
11719 tempmask = sigsetmask(*set);
11722 tempmask = sigblock(*set);
11725 tempmask = sigblock(0);
11726 sigsetmask(*oset & ~tempmask);
11729 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11734 /* Did they pass us an oset? If so, stick our holding mask into it */
11741 #endif /* HOMEGROWN_POSIX_SIGNALS */
11744 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11745 * my_utime(), and flex_stat(), all of which operate on UTC unless
11746 * VMSISH_TIMES is true.
11748 /* method used to handle UTC conversions:
11749 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
11751 static int gmtime_emulation_type;
11752 /* number of secs to add to UTC POSIX-style time to get local time */
11753 static long int utc_offset_secs;
11755 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11756 * in vmsish.h. #undef them here so we can call the CRTL routines
11765 * DEC C previous to 6.0 corrupts the behavior of the /prefix
11766 * qualifier with the extern prefix pragma. This provisional
11767 * hack circumvents this prefix pragma problem in previous
11770 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11771 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11772 # pragma __extern_prefix save
11773 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
11774 # define gmtime decc$__utctz_gmtime
11775 # define localtime decc$__utctz_localtime
11776 # define time decc$__utc_time
11777 # pragma __extern_prefix restore
11779 struct tm *gmtime(), *localtime();
11785 static time_t toutc_dst(time_t loc) {
11788 if ((rsltmp = localtime(&loc)) == NULL) return -1;
11789 loc -= utc_offset_secs;
11790 if (rsltmp->tm_isdst) loc -= 3600;
11793 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11794 ((gmtime_emulation_type || my_time(NULL)), \
11795 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11796 ((secs) - utc_offset_secs))))
11798 static time_t toloc_dst(time_t utc) {
11801 utc += utc_offset_secs;
11802 if ((rsltmp = localtime(&utc)) == NULL) return -1;
11803 if (rsltmp->tm_isdst) utc += 3600;
11806 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11807 ((gmtime_emulation_type || my_time(NULL)), \
11808 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11809 ((secs) + utc_offset_secs))))
11811 #ifndef RTL_USES_UTC
11814 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
11815 DST starts on 1st sun of april at 02:00 std time
11816 ends on last sun of october at 02:00 dst time
11817 see the UCX management command reference, SET CONFIG TIMEZONE
11818 for formatting info.
11820 No, it's not as general as it should be, but then again, NOTHING
11821 will handle UK times in a sensible way.
11826 parse the DST start/end info:
11827 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11831 tz_parse_startend(char *s, struct tm *w, int *past)
11833 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11834 int ly, dozjd, d, m, n, hour, min, sec, j, k;
11839 if (!past) return 0;
11842 if (w->tm_year % 4 == 0) ly = 1;
11843 if (w->tm_year % 100 == 0) ly = 0;
11844 if (w->tm_year+1900 % 400 == 0) ly = 1;
11847 dozjd = isdigit(*s);
11848 if (*s == 'J' || *s == 'j' || dozjd) {
11849 if (!dozjd && !isdigit(*++s)) return 0;
11852 d = d*10 + *s++ - '0';
11854 d = d*10 + *s++ - '0';
11857 if (d == 0) return 0;
11858 if (d > 366) return 0;
11860 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
11863 } else if (*s == 'M' || *s == 'm') {
11864 if (!isdigit(*++s)) return 0;
11866 if (isdigit(*s)) m = 10*m + *s++ - '0';
11867 if (*s != '.') return 0;
11868 if (!isdigit(*++s)) return 0;
11870 if (n < 1 || n > 5) return 0;
11871 if (*s != '.') return 0;
11872 if (!isdigit(*++s)) return 0;
11874 if (d > 6) return 0;
11878 if (!isdigit(*++s)) return 0;
11880 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11882 if (!isdigit(*++s)) return 0;
11884 if (isdigit(*s)) min = 10*min + *s++ - '0';
11886 if (!isdigit(*++s)) return 0;
11888 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11898 if (w->tm_yday < d) goto before;
11899 if (w->tm_yday > d) goto after;
11901 if (w->tm_mon+1 < m) goto before;
11902 if (w->tm_mon+1 > m) goto after;
11904 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
11905 k = d - j; /* mday of first d */
11906 if (k <= 0) k += 7;
11907 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
11908 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11909 if (w->tm_mday < k) goto before;
11910 if (w->tm_mday > k) goto after;
11913 if (w->tm_hour < hour) goto before;
11914 if (w->tm_hour > hour) goto after;
11915 if (w->tm_min < min) goto before;
11916 if (w->tm_min > min) goto after;
11917 if (w->tm_sec < sec) goto before;
11931 /* parse the offset: (+|-)hh[:mm[:ss]] */
11934 tz_parse_offset(char *s, int *offset)
11936 int hour = 0, min = 0, sec = 0;
11939 if (!offset) return 0;
11941 if (*s == '-') {neg++; s++;}
11942 if (*s == '+') s++;
11943 if (!isdigit(*s)) return 0;
11945 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11946 if (hour > 24) return 0;
11948 if (!isdigit(*++s)) return 0;
11950 if (isdigit(*s)) min = min*10 + (*s++ - '0');
11951 if (min > 59) return 0;
11953 if (!isdigit(*++s)) return 0;
11955 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11956 if (sec > 59) return 0;
11960 *offset = (hour*60+min)*60 + sec;
11961 if (neg) *offset = -*offset;
11966 input time is w, whatever type of time the CRTL localtime() uses.
11967 sets dst, the zone, and the gmtoff (seconds)
11969 caches the value of TZ and UCX$TZ env variables; note that
11970 my_setenv looks for these and sets a flag if they're changed
11973 We have to watch out for the "australian" case (dst starts in
11974 october, ends in april)...flagged by "reverse" and checked by
11975 scanning through the months of the previous year.
11980 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11985 char *dstzone, *tz, *s_start, *s_end;
11986 int std_off, dst_off, isdst;
11987 int y, dststart, dstend;
11988 static char envtz[1025]; /* longer than any logical, symbol, ... */
11989 static char ucxtz[1025];
11990 static char reversed = 0;
11996 reversed = -1; /* flag need to check */
11997 envtz[0] = ucxtz[0] = '\0';
11998 tz = my_getenv("TZ",0);
11999 if (tz) strcpy(envtz, tz);
12000 tz = my_getenv("UCX$TZ",0);
12001 if (tz) strcpy(ucxtz, tz);
12002 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
12005 if (!*tz) tz = ucxtz;
12008 while (isalpha(*s)) s++;
12009 s = tz_parse_offset(s, &std_off);
12011 if (!*s) { /* no DST, hurray we're done! */
12017 while (isalpha(*s)) s++;
12018 s2 = tz_parse_offset(s, &dst_off);
12022 dst_off = std_off - 3600;
12025 if (!*s) { /* default dst start/end?? */
12026 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
12027 s = strchr(ucxtz,',');
12029 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
12031 if (*s != ',') return 0;
12034 when = _toutc(when); /* convert to utc */
12035 when = when - std_off; /* convert to pseudolocal time*/
12037 w2 = localtime(&when);
12040 s = tz_parse_startend(s_start,w2,&dststart);
12042 if (*s != ',') return 0;
12045 when = _toutc(when); /* convert to utc */
12046 when = when - dst_off; /* convert to pseudolocal time*/
12047 w2 = localtime(&when);
12048 if (w2->tm_year != y) { /* spans a year, just check one time */
12049 when += dst_off - std_off;
12050 w2 = localtime(&when);
12053 s = tz_parse_startend(s_end,w2,&dstend);
12056 if (reversed == -1) { /* need to check if start later than end */
12060 if (when < 2*365*86400) {
12061 when += 2*365*86400;
12065 w2 =localtime(&when);
12066 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
12068 for (j = 0; j < 12; j++) {
12069 w2 =localtime(&when);
12070 tz_parse_startend(s_start,w2,&ds);
12071 tz_parse_startend(s_end,w2,&de);
12072 if (ds != de) break;
12076 if (de && !ds) reversed = 1;
12079 isdst = dststart && !dstend;
12080 if (reversed) isdst = dststart || !dstend;
12083 if (dst) *dst = isdst;
12084 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
12085 if (isdst) tz = dstzone;
12087 while(isalpha(*tz)) *zone++ = *tz++;
12093 #endif /* !RTL_USES_UTC */
12095 /* my_time(), my_localtime(), my_gmtime()
12096 * By default traffic in UTC time values, using CRTL gmtime() or
12097 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
12098 * Note: We need to use these functions even when the CRTL has working
12099 * UTC support, since they also handle C<use vmsish qw(times);>
12101 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
12102 * Modified by Charles Bailey <bailey@newman.upenn.edu>
12105 /*{{{time_t my_time(time_t *timep)*/
12106 time_t Perl_my_time(pTHX_ time_t *timep)
12111 if (gmtime_emulation_type == 0) {
12113 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
12114 /* results of calls to gmtime() and localtime() */
12115 /* for same &base */
12117 gmtime_emulation_type++;
12118 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
12119 char off[LNM$C_NAMLENGTH+1];;
12121 gmtime_emulation_type++;
12122 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
12123 gmtime_emulation_type++;
12124 utc_offset_secs = 0;
12125 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
12127 else { utc_offset_secs = atol(off); }
12129 else { /* We've got a working gmtime() */
12130 struct tm gmt, local;
12133 tm_p = localtime(&base);
12135 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
12136 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
12137 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
12138 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
12143 # ifdef VMSISH_TIME
12144 # ifdef RTL_USES_UTC
12145 if (VMSISH_TIME) when = _toloc(when);
12147 if (!VMSISH_TIME) when = _toutc(when);
12150 if (timep != NULL) *timep = when;
12153 } /* end of my_time() */
12157 /*{{{struct tm *my_gmtime(const time_t *timep)*/
12159 Perl_my_gmtime(pTHX_ const time_t *timep)
12165 if (timep == NULL) {
12166 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12169 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
12172 # ifdef VMSISH_TIME
12173 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
12175 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
12176 return gmtime(&when);
12178 /* CRTL localtime() wants local time as input, so does no tz correction */
12179 rsltmp = localtime(&when);
12180 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
12183 } /* end of my_gmtime() */
12187 /*{{{struct tm *my_localtime(const time_t *timep)*/
12189 Perl_my_localtime(pTHX_ const time_t *timep)
12191 time_t when, whenutc;
12195 if (timep == NULL) {
12196 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12199 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
12200 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
12203 # ifdef RTL_USES_UTC
12204 # ifdef VMSISH_TIME
12205 if (VMSISH_TIME) when = _toutc(when);
12207 /* CRTL localtime() wants UTC as input, does tz correction itself */
12208 return localtime(&when);
12210 # else /* !RTL_USES_UTC */
12212 # ifdef VMSISH_TIME
12213 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
12214 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
12217 #ifndef RTL_USES_UTC
12218 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
12219 when = whenutc - offset; /* pseudolocal time*/
12222 /* CRTL localtime() wants local time as input, so does no tz correction */
12223 rsltmp = localtime(&when);
12224 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12228 } /* end of my_localtime() */
12231 /* Reset definitions for later calls */
12232 #define gmtime(t) my_gmtime(t)
12233 #define localtime(t) my_localtime(t)
12234 #define time(t) my_time(t)
12237 /* my_utime - update modification/access time of a file
12239 * VMS 7.3 and later implementation
12240 * Only the UTC translation is home-grown. The rest is handled by the
12241 * CRTL utime(), which will take into account the relevant feature
12242 * logicals and ODS-5 volume characteristics for true access times.
12244 * pre VMS 7.3 implementation:
12245 * The calling sequence is identical to POSIX utime(), but under
12246 * VMS with ODS-2, only the modification time is changed; ODS-2 does
12247 * not maintain access times. Restrictions differ from the POSIX
12248 * definition in that the time can be changed as long as the
12249 * caller has permission to execute the necessary IO$_MODIFY $QIO;
12250 * no separate checks are made to insure that the caller is the
12251 * owner of the file or has special privs enabled.
12252 * Code here is based on Joe Meadows' FILE utility.
12256 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12257 * to VMS epoch (01-JAN-1858 00:00:00.00)
12258 * in 100 ns intervals.
12260 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12262 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12263 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12265 #if __CRTL_VER >= 70300000
12266 struct utimbuf utc_utimes, *utc_utimesp;
12268 if (utimes != NULL) {
12269 utc_utimes.actime = utimes->actime;
12270 utc_utimes.modtime = utimes->modtime;
12271 # ifdef VMSISH_TIME
12272 /* If input was local; convert to UTC for sys svc */
12274 utc_utimes.actime = _toutc(utimes->actime);
12275 utc_utimes.modtime = _toutc(utimes->modtime);
12278 utc_utimesp = &utc_utimes;
12281 utc_utimesp = NULL;
12284 return utime(file, utc_utimesp);
12286 #else /* __CRTL_VER < 70300000 */
12290 long int bintime[2], len = 2, lowbit, unixtime,
12291 secscale = 10000000; /* seconds --> 100 ns intervals */
12292 unsigned long int chan, iosb[2], retsts;
12293 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12294 struct FAB myfab = cc$rms_fab;
12295 struct NAM mynam = cc$rms_nam;
12296 #if defined (__DECC) && defined (__VAX)
12297 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12298 * at least through VMS V6.1, which causes a type-conversion warning.
12300 # pragma message save
12301 # pragma message disable cvtdiftypes
12303 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12304 struct fibdef myfib;
12305 #if defined (__DECC) && defined (__VAX)
12306 /* This should be right after the declaration of myatr, but due
12307 * to a bug in VAX DEC C, this takes effect a statement early.
12309 # pragma message restore
12311 /* cast ok for read only parameter */
12312 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12313 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12314 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12316 if (file == NULL || *file == '\0') {
12317 SETERRNO(ENOENT, LIB$_INVARG);
12321 /* Convert to VMS format ensuring that it will fit in 255 characters */
12322 if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12323 SETERRNO(ENOENT, LIB$_INVARG);
12326 if (utimes != NULL) {
12327 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
12328 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12329 * Since time_t is unsigned long int, and lib$emul takes a signed long int
12330 * as input, we force the sign bit to be clear by shifting unixtime right
12331 * one bit, then multiplying by an extra factor of 2 in lib$emul().
12333 lowbit = (utimes->modtime & 1) ? secscale : 0;
12334 unixtime = (long int) utimes->modtime;
12335 # ifdef VMSISH_TIME
12336 /* If input was UTC; convert to local for sys svc */
12337 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12339 unixtime >>= 1; secscale <<= 1;
12340 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12341 if (!(retsts & 1)) {
12342 SETERRNO(EVMSERR, retsts);
12345 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12346 if (!(retsts & 1)) {
12347 SETERRNO(EVMSERR, retsts);
12352 /* Just get the current time in VMS format directly */
12353 retsts = sys$gettim(bintime);
12354 if (!(retsts & 1)) {
12355 SETERRNO(EVMSERR, retsts);
12360 myfab.fab$l_fna = vmsspec;
12361 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12362 myfab.fab$l_nam = &mynam;
12363 mynam.nam$l_esa = esa;
12364 mynam.nam$b_ess = (unsigned char) sizeof esa;
12365 mynam.nam$l_rsa = rsa;
12366 mynam.nam$b_rss = (unsigned char) sizeof rsa;
12367 if (decc_efs_case_preserve)
12368 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12370 /* Look for the file to be affected, letting RMS parse the file
12371 * specification for us as well. I have set errno using only
12372 * values documented in the utime() man page for VMS POSIX.
12374 retsts = sys$parse(&myfab,0,0);
12375 if (!(retsts & 1)) {
12376 set_vaxc_errno(retsts);
12377 if (retsts == RMS$_PRV) set_errno(EACCES);
12378 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12379 else set_errno(EVMSERR);
12382 retsts = sys$search(&myfab,0,0);
12383 if (!(retsts & 1)) {
12384 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12385 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12386 set_vaxc_errno(retsts);
12387 if (retsts == RMS$_PRV) set_errno(EACCES);
12388 else if (retsts == RMS$_FNF) set_errno(ENOENT);
12389 else set_errno(EVMSERR);
12393 devdsc.dsc$w_length = mynam.nam$b_dev;
12394 /* cast ok for read only parameter */
12395 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12397 retsts = sys$assign(&devdsc,&chan,0,0);
12398 if (!(retsts & 1)) {
12399 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12400 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12401 set_vaxc_errno(retsts);
12402 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
12403 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
12404 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
12405 else set_errno(EVMSERR);
12409 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12410 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12412 memset((void *) &myfib, 0, sizeof myfib);
12413 #if defined(__DECC) || defined(__DECCXX)
12414 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12415 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12416 /* This prevents the revision time of the file being reset to the current
12417 * time as a result of our IO$_MODIFY $QIO. */
12418 myfib.fib$l_acctl = FIB$M_NORECORD;
12420 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12421 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12422 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12424 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12425 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12426 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12427 _ckvmssts(sys$dassgn(chan));
12428 if (retsts & 1) retsts = iosb[0];
12429 if (!(retsts & 1)) {
12430 set_vaxc_errno(retsts);
12431 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12432 else set_errno(EVMSERR);
12438 #endif /* #if __CRTL_VER >= 70300000 */
12440 } /* end of my_utime() */
12444 * flex_stat, flex_lstat, flex_fstat
12445 * basic stat, but gets it right when asked to stat
12446 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12449 #ifndef _USE_STD_STAT
12450 /* encode_dev packs a VMS device name string into an integer to allow
12451 * simple comparisons. This can be used, for example, to check whether two
12452 * files are located on the same device, by comparing their encoded device
12453 * names. Even a string comparison would not do, because stat() reuses the
12454 * device name buffer for each call; so without encode_dev, it would be
12455 * necessary to save the buffer and use strcmp (this would mean a number of
12456 * changes to the standard Perl code, to say nothing of what a Perl script
12457 * would have to do.
12459 * The device lock id, if it exists, should be unique (unless perhaps compared
12460 * with lock ids transferred from other nodes). We have a lock id if the disk is
12461 * mounted cluster-wide, which is when we tend to get long (host-qualified)
12462 * device names. Thus we use the lock id in preference, and only if that isn't
12463 * available, do we try to pack the device name into an integer (flagged by
12464 * the sign bit (LOCKID_MASK) being set).
12466 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12467 * name and its encoded form, but it seems very unlikely that we will find
12468 * two files on different disks that share the same encoded device names,
12469 * and even more remote that they will share the same file id (if the test
12470 * is to check for the same file).
12472 * A better method might be to use sys$device_scan on the first call, and to
12473 * search for the device, returning an index into the cached array.
12474 * The number returned would be more intelligible.
12475 * This is probably not worth it, and anyway would take quite a bit longer
12476 * on the first call.
12478 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
12479 static mydev_t encode_dev (pTHX_ const char *dev)
12482 unsigned long int f;
12487 if (!dev || !dev[0]) return 0;
12491 struct dsc$descriptor_s dev_desc;
12492 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12494 /* For cluster-mounted disks, the disk lock identifier is unique, so we
12495 can try that first. */
12496 dev_desc.dsc$w_length = strlen (dev);
12497 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
12498 dev_desc.dsc$b_class = DSC$K_CLASS_S;
12499 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
12500 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12501 if (!$VMS_STATUS_SUCCESS(status)) {
12503 case SS$_NOSUCHDEV:
12504 SETERRNO(ENODEV, status);
12510 if (lockid) return (lockid & ~LOCKID_MASK);
12514 /* Otherwise we try to encode the device name */
12518 for (q = dev + strlen(dev); q--; q >= dev) {
12523 else if (isalpha (toupper (*q)))
12524 c= toupper (*q) - 'A' + (char)10;
12526 continue; /* Skip '$'s */
12528 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
12530 enc += f * (unsigned long int) c;
12532 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
12534 } /* end of encode_dev() */
12535 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12536 device_no = encode_dev(aTHX_ devname)
12538 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12539 device_no = new_dev_no
12543 is_null_device(name)
12546 if (decc_bug_devnull != 0) {
12547 if (strncmp("/dev/null", name, 9) == 0)
12550 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12551 The underscore prefix, controller letter, and unit number are
12552 independently optional; for our purposes, the colon punctuation
12553 is not. The colon can be trailed by optional directory and/or
12554 filename, but two consecutive colons indicates a nodename rather
12555 than a device. [pr] */
12556 if (*name == '_') ++name;
12557 if (tolower(*name++) != 'n') return 0;
12558 if (tolower(*name++) != 'l') return 0;
12559 if (tolower(*name) == 'a') ++name;
12560 if (*name == '0') ++name;
12561 return (*name++ == ':') && (*name != ':');
12565 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
12567 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
12570 Perl_cando_by_name_int
12571 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12573 char usrname[L_cuserid];
12574 struct dsc$descriptor_s usrdsc =
12575 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12576 char *vmsname = NULL, *fileified = NULL;
12577 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12578 unsigned short int retlen, trnlnm_iter_count;
12579 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12580 union prvdef curprv;
12581 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12582 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12583 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12584 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12585 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12587 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12589 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12591 static int profile_context = -1;
12593 if (!fname || !*fname) return FALSE;
12595 /* Make sure we expand logical names, since sys$check_access doesn't */
12596 fileified = PerlMem_malloc(VMS_MAXRSS);
12597 if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12598 if (!strpbrk(fname,"/]>:")) {
12599 strcpy(fileified,fname);
12600 trnlnm_iter_count = 0;
12601 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12602 trnlnm_iter_count++;
12603 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12608 vmsname = PerlMem_malloc(VMS_MAXRSS);
12609 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12610 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12611 /* Don't know if already in VMS format, so make sure */
12612 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12613 PerlMem_free(fileified);
12614 PerlMem_free(vmsname);
12619 strcpy(vmsname,fname);
12622 /* sys$check_access needs a file spec, not a directory spec.
12623 * flex_stat now will handle a null thread context during startup.
12626 retlen = namdsc.dsc$w_length = strlen(vmsname);
12627 if (vmsname[retlen-1] == ']'
12628 || vmsname[retlen-1] == '>'
12629 || vmsname[retlen-1] == ':'
12630 || (!flex_stat_int(vmsname, &st, 1) &&
12631 S_ISDIR(st.st_mode))) {
12633 if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12634 PerlMem_free(fileified);
12635 PerlMem_free(vmsname);
12644 retlen = namdsc.dsc$w_length = strlen(fname);
12645 namdsc.dsc$a_pointer = (char *)fname;
12648 case S_IXUSR: case S_IXGRP: case S_IXOTH:
12649 access = ARM$M_EXECUTE;
12650 flags = CHP$M_READ;
12652 case S_IRUSR: case S_IRGRP: case S_IROTH:
12653 access = ARM$M_READ;
12654 flags = CHP$M_READ | CHP$M_USEREADALL;
12656 case S_IWUSR: case S_IWGRP: case S_IWOTH:
12657 access = ARM$M_WRITE;
12658 flags = CHP$M_READ | CHP$M_WRITE;
12660 case S_IDUSR: case S_IDGRP: case S_IDOTH:
12661 access = ARM$M_DELETE;
12662 flags = CHP$M_READ | CHP$M_WRITE;
12665 if (fileified != NULL)
12666 PerlMem_free(fileified);
12667 if (vmsname != NULL)
12668 PerlMem_free(vmsname);
12672 /* Before we call $check_access, create a user profile with the current
12673 * process privs since otherwise it just uses the default privs from the
12674 * UAF and might give false positives or negatives. This only works on
12675 * VMS versions v6.0 and later since that's when sys$create_user_profile
12676 * became available.
12679 /* get current process privs and username */
12680 _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12681 _ckvmssts_noperl(iosb[0]);
12683 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12685 /* find out the space required for the profile */
12686 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12687 &usrprodsc.dsc$w_length,&profile_context));
12689 /* allocate space for the profile and get it filled in */
12690 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12691 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12692 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12693 &usrprodsc.dsc$w_length,&profile_context));
12695 /* use the profile to check access to the file; free profile & analyze results */
12696 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12697 PerlMem_free(usrprodsc.dsc$a_pointer);
12698 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12702 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12706 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
12707 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12708 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12709 set_vaxc_errno(retsts);
12710 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12711 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12712 else set_errno(ENOENT);
12713 if (fileified != NULL)
12714 PerlMem_free(fileified);
12715 if (vmsname != NULL)
12716 PerlMem_free(vmsname);
12719 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12720 if (fileified != NULL)
12721 PerlMem_free(fileified);
12722 if (vmsname != NULL)
12723 PerlMem_free(vmsname);
12726 _ckvmssts_noperl(retsts);
12728 if (fileified != NULL)
12729 PerlMem_free(fileified);
12730 if (vmsname != NULL)
12731 PerlMem_free(vmsname);
12732 return FALSE; /* Should never get here */
12736 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
12737 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12738 * subset of the applicable information.
12741 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12743 return cando_by_name_int
12744 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12745 } /* end of cando() */
12749 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12751 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12753 return cando_by_name_int(bit, effective, fname, 0);
12755 } /* end of cando_by_name() */
12759 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12761 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12763 if (!fstat(fd, &statbufp->crtl_stat)) {
12765 char *vms_filename;
12766 vms_filename = PerlMem_malloc(VMS_MAXRSS);
12767 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12769 /* Save name for cando by name in VMS format */
12770 cptr = getname(fd, vms_filename, 1);
12772 /* This should not happen, but just in case */
12773 if (cptr == NULL) {
12774 statbufp->st_devnam[0] = 0;
12777 /* Make sure that the saved name fits in 255 characters */
12778 cptr = int_rmsexpand_vms
12780 statbufp->st_devnam,
12783 statbufp->st_devnam[0] = 0;
12785 PerlMem_free(vms_filename);
12787 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12789 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12791 # ifdef RTL_USES_UTC
12792 # ifdef VMSISH_TIME
12794 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12795 statbufp->st_atime = _toloc(statbufp->st_atime);
12796 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12800 # ifdef VMSISH_TIME
12801 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12805 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12806 statbufp->st_atime = _toutc(statbufp->st_atime);
12807 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12814 } /* end of flex_fstat() */
12818 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12822 const char *save_spec;
12833 if (decc_bug_devnull != 0) {
12834 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12835 memset(statbufp,0,sizeof *statbufp);
12836 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12837 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12838 statbufp->st_uid = 0x00010001;
12839 statbufp->st_gid = 0x0001;
12840 time((time_t *)&statbufp->st_mtime);
12841 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12846 /* Try for a directory name first. If fspec contains a filename without
12847 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12848 * and sea:[wine.dark]water. exist, we prefer the directory here.
12849 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12850 * not sea:[wine.dark]., if the latter exists. If the intended target is
12851 * the file with null type, specify this by calling flex_stat() with
12852 * a '.' at the end of fspec.
12854 * If we are in Posix filespec mode, accept the filename as is.
12858 fileified = PerlMem_malloc(VMS_MAXRSS);
12859 if (fileified == NULL)
12860 _ckvmssts_noperl(SS$_INSFMEM);
12862 temp_fspec = PerlMem_malloc(VMS_MAXRSS);
12863 if (temp_fspec == NULL)
12864 _ckvmssts_noperl(SS$_INSFMEM);
12866 strcpy(temp_fspec, fspec);
12870 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12871 if (decc_posix_compliant_pathnames == 0) {
12874 /* We may be able to optimize this, but in order for fileify_dirspec to
12875 * always return a usuable answer, we have to call vmspath first to
12876 * make sure that it is in VMS directory format, as stat/lstat on 8.3
12877 * can not handle directories in unix format that it does not have read
12878 * access to. Vmspath handles the case where a bare name which could be
12879 * a logical name gets passed.
12881 ret_spec = int_tovmspath(fspec, temp_fspec, NULL);
12882 if (ret_spec != NULL) {
12883 ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
12884 if (ret_spec != NULL) {
12885 if (lstat_flag == 0)
12886 retval = stat(fileified, &statbufp->crtl_stat);
12888 retval = lstat(fileified, &statbufp->crtl_stat);
12889 save_spec = fileified;
12893 if (retval && vms_bug_stat_filename) {
12895 /* We should try again as a vmsified file specification */
12896 /* However Perl traditionally has not done this, which */
12897 /* causes problems with existing tests */
12899 ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12900 if (ret_spec != NULL) {
12901 if (lstat_flag == 0)
12902 retval = stat(temp_fspec, &statbufp->crtl_stat);
12904 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12905 save_spec = temp_fspec;
12910 /* Last chance - allow multiple dots with out EFS CHARSET */
12911 /* The CRTL stat() falls down hard on multi-dot filenames in unix
12912 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12913 * enable it if it isn't already.
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, 1);
12919 if (lstat_flag == 0)
12920 retval = stat(fspec, &statbufp->crtl_stat);
12922 retval = lstat(fspec, &statbufp->crtl_stat);
12924 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12925 if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12926 decc$feature_set_value(decc_efs_charset_index, 1, 0);
12932 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12934 if (lstat_flag == 0)
12935 retval = stat(temp_fspec, &statbufp->crtl_stat);
12937 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12938 save_spec = temp_fspec;
12942 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12943 /* As you were... */
12944 if (!decc_efs_charset)
12945 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12950 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12952 /* If this is an lstat, do not follow the link */
12954 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12956 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12957 /* If we used the efs_hack above, we must also use it here for */
12958 /* perl_cando to work */
12959 if (efs_hack && (decc_efs_charset_index > 0)) {
12960 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12963 cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12964 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12965 if (efs_hack && (decc_efs_charset_index > 0)) {
12966 decc$feature_set_value(decc_efs_charset, 1, 0);
12970 /* Fix me: If this is NULL then stat found a file, and we could */
12971 /* not convert the specification to VMS - Should never happen */
12973 statbufp->st_devnam[0] = 0;
12975 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12977 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12978 # ifdef RTL_USES_UTC
12979 # ifdef VMSISH_TIME
12981 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12982 statbufp->st_atime = _toloc(statbufp->st_atime);
12983 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12987 # ifdef VMSISH_TIME
12988 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12992 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12993 statbufp->st_atime = _toutc(statbufp->st_atime);
12994 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12998 /* If we were successful, leave errno where we found it */
12999 if (retval == 0) RESTORE_ERRNO;
13002 } /* end of flex_stat_int() */
13005 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
13007 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
13009 return flex_stat_int(fspec, statbufp, 0);
13013 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
13015 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
13017 return flex_stat_int(fspec, statbufp, 1);
13022 /*{{{char *my_getlogin()*/
13023 /* VMS cuserid == Unix getlogin, except calling sequence */
13027 static char user[L_cuserid];
13028 return cuserid(user);
13033 /* rmscopy - copy a file using VMS RMS routines
13035 * Copies contents and attributes of spec_in to spec_out, except owner
13036 * and protection information. Name and type of spec_in are used as
13037 * defaults for spec_out. The third parameter specifies whether rmscopy()
13038 * should try to propagate timestamps from the input file to the output file.
13039 * If it is less than 0, no timestamps are preserved. If it is 0, then
13040 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
13041 * propagated to the output file at creation iff the output file specification
13042 * did not contain an explicit name or type, and the revision date is always
13043 * updated at the end of the copy operation. If it is greater than 0, then
13044 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
13045 * other than the revision date should be propagated, and bit 1 indicates
13046 * that the revision date should be propagated.
13048 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
13050 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
13051 * Incorporates, with permission, some code from EZCOPY by Tim Adye
13052 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
13053 * as part of the Perl standard distribution under the terms of the
13054 * GNU General Public License or the Perl Artistic License. Copies
13055 * of each may be found in the Perl standard distribution.
13057 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
13059 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
13061 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
13062 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
13063 unsigned long int i, sts, sts2;
13065 struct FAB fab_in, fab_out;
13066 struct RAB rab_in, rab_out;
13067 rms_setup_nam(nam);
13068 rms_setup_nam(nam_out);
13069 struct XABDAT xabdat;
13070 struct XABFHC xabfhc;
13071 struct XABRDT xabrdt;
13072 struct XABSUM xabsum;
13074 vmsin = PerlMem_malloc(VMS_MAXRSS);
13075 if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13076 vmsout = PerlMem_malloc(VMS_MAXRSS);
13077 if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13078 if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
13079 !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
13080 PerlMem_free(vmsin);
13081 PerlMem_free(vmsout);
13082 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13086 esa = PerlMem_malloc(VMS_MAXRSS);
13087 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13089 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13090 esal = PerlMem_malloc(VMS_MAXRSS);
13091 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13093 fab_in = cc$rms_fab;
13094 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
13095 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
13096 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
13097 fab_in.fab$l_fop = FAB$M_SQO;
13098 rms_bind_fab_nam(fab_in, nam);
13099 fab_in.fab$l_xab = (void *) &xabdat;
13101 rsa = PerlMem_malloc(VMS_MAXRSS);
13102 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13104 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13105 rsal = PerlMem_malloc(VMS_MAXRSS);
13106 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13108 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
13109 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
13110 rms_nam_esl(nam) = 0;
13111 rms_nam_rsl(nam) = 0;
13112 rms_nam_esll(nam) = 0;
13113 rms_nam_rsll(nam) = 0;
13114 #ifdef NAM$M_NO_SHORT_UPCASE
13115 if (decc_efs_case_preserve)
13116 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
13119 xabdat = cc$rms_xabdat; /* To get creation date */
13120 xabdat.xab$l_nxt = (void *) &xabfhc;
13122 xabfhc = cc$rms_xabfhc; /* To get record length */
13123 xabfhc.xab$l_nxt = (void *) &xabsum;
13125 xabsum = cc$rms_xabsum; /* To get key and area information */
13127 if (!((sts = sys$open(&fab_in)) & 1)) {
13128 PerlMem_free(vmsin);
13129 PerlMem_free(vmsout);
13132 PerlMem_free(esal);
13135 PerlMem_free(rsal);
13136 set_vaxc_errno(sts);
13138 case RMS$_FNF: case RMS$_DNF:
13139 set_errno(ENOENT); break;
13141 set_errno(ENOTDIR); break;
13143 set_errno(ENODEV); break;
13145 set_errno(EINVAL); break;
13147 set_errno(EACCES); break;
13149 set_errno(EVMSERR);
13156 fab_out.fab$w_ifi = 0;
13157 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
13158 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
13159 fab_out.fab$l_fop = FAB$M_SQO;
13160 rms_bind_fab_nam(fab_out, nam_out);
13161 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
13162 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
13163 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
13164 esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13165 if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13166 rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13167 if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13170 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13171 esal_out = PerlMem_malloc(VMS_MAXRSS);
13172 if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13173 rsal_out = PerlMem_malloc(VMS_MAXRSS);
13174 if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13176 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
13177 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
13179 if (preserve_dates == 0) { /* Act like DCL COPY */
13180 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
13181 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
13182 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
13183 PerlMem_free(vmsin);
13184 PerlMem_free(vmsout);
13187 PerlMem_free(esal);
13190 PerlMem_free(rsal);
13191 PerlMem_free(esa_out);
13192 if (esal_out != NULL)
13193 PerlMem_free(esal_out);
13194 PerlMem_free(rsa_out);
13195 if (rsal_out != NULL)
13196 PerlMem_free(rsal_out);
13197 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
13198 set_vaxc_errno(sts);
13201 fab_out.fab$l_xab = (void *) &xabdat;
13202 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
13203 preserve_dates = 1;
13205 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
13206 preserve_dates =0; /* bitmask from this point forward */
13208 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
13209 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
13210 PerlMem_free(vmsin);
13211 PerlMem_free(vmsout);
13214 PerlMem_free(esal);
13217 PerlMem_free(rsal);
13218 PerlMem_free(esa_out);
13219 if (esal_out != NULL)
13220 PerlMem_free(esal_out);
13221 PerlMem_free(rsa_out);
13222 if (rsal_out != NULL)
13223 PerlMem_free(rsal_out);
13224 set_vaxc_errno(sts);
13227 set_errno(ENOENT); break;
13229 set_errno(ENOTDIR); break;
13231 set_errno(ENODEV); break;
13233 set_errno(EINVAL); break;
13235 set_errno(EACCES); break;
13237 set_errno(EVMSERR);
13241 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
13242 if (preserve_dates & 2) {
13243 /* sys$close() will process xabrdt, not xabdat */
13244 xabrdt = cc$rms_xabrdt;
13246 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
13248 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
13249 * is unsigned long[2], while DECC & VAXC use a struct */
13250 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
13252 fab_out.fab$l_xab = (void *) &xabrdt;
13255 ubf = PerlMem_malloc(32256);
13256 if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13257 rab_in = cc$rms_rab;
13258 rab_in.rab$l_fab = &fab_in;
13259 rab_in.rab$l_rop = RAB$M_BIO;
13260 rab_in.rab$l_ubf = ubf;
13261 rab_in.rab$w_usz = 32256;
13262 if (!((sts = sys$connect(&rab_in)) & 1)) {
13263 sys$close(&fab_in); sys$close(&fab_out);
13264 PerlMem_free(vmsin);
13265 PerlMem_free(vmsout);
13269 PerlMem_free(esal);
13272 PerlMem_free(rsal);
13273 PerlMem_free(esa_out);
13274 if (esal_out != NULL)
13275 PerlMem_free(esal_out);
13276 PerlMem_free(rsa_out);
13277 if (rsal_out != NULL)
13278 PerlMem_free(rsal_out);
13279 set_errno(EVMSERR); set_vaxc_errno(sts);
13283 rab_out = cc$rms_rab;
13284 rab_out.rab$l_fab = &fab_out;
13285 rab_out.rab$l_rbf = ubf;
13286 if (!((sts = sys$connect(&rab_out)) & 1)) {
13287 sys$close(&fab_in); sys$close(&fab_out);
13288 PerlMem_free(vmsin);
13289 PerlMem_free(vmsout);
13293 PerlMem_free(esal);
13296 PerlMem_free(rsal);
13297 PerlMem_free(esa_out);
13298 if (esal_out != NULL)
13299 PerlMem_free(esal_out);
13300 PerlMem_free(rsa_out);
13301 if (rsal_out != NULL)
13302 PerlMem_free(rsal_out);
13303 set_errno(EVMSERR); set_vaxc_errno(sts);
13307 while ((sts = sys$read(&rab_in))) { /* always true */
13308 if (sts == RMS$_EOF) break;
13309 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13310 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13311 sys$close(&fab_in); sys$close(&fab_out);
13312 PerlMem_free(vmsin);
13313 PerlMem_free(vmsout);
13317 PerlMem_free(esal);
13320 PerlMem_free(rsal);
13321 PerlMem_free(esa_out);
13322 if (esal_out != NULL)
13323 PerlMem_free(esal_out);
13324 PerlMem_free(rsa_out);
13325 if (rsal_out != NULL)
13326 PerlMem_free(rsal_out);
13327 set_errno(EVMSERR); set_vaxc_errno(sts);
13333 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
13334 sys$close(&fab_in); sys$close(&fab_out);
13335 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13337 PerlMem_free(vmsin);
13338 PerlMem_free(vmsout);
13342 PerlMem_free(esal);
13345 PerlMem_free(rsal);
13346 PerlMem_free(esa_out);
13347 if (esal_out != NULL)
13348 PerlMem_free(esal_out);
13349 PerlMem_free(rsa_out);
13350 if (rsal_out != NULL)
13351 PerlMem_free(rsal_out);
13354 set_errno(EVMSERR); set_vaxc_errno(sts);
13360 } /* end of rmscopy() */
13364 /*** The following glue provides 'hooks' to make some of the routines
13365 * from this file available from Perl. These routines are sufficiently
13366 * basic, and are required sufficiently early in the build process,
13367 * that's it's nice to have them available to miniperl as well as the
13368 * full Perl, so they're set up here instead of in an extension. The
13369 * Perl code which handles importation of these names into a given
13370 * package lives in [.VMS]Filespec.pm in @INC.
13374 rmsexpand_fromperl(pTHX_ CV *cv)
13377 char *fspec, *defspec = NULL, *rslt;
13379 int fs_utf8, dfs_utf8;
13383 if (!items || items > 2)
13384 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13385 fspec = SvPV(ST(0),n_a);
13386 fs_utf8 = SvUTF8(ST(0));
13387 if (!fspec || !*fspec) XSRETURN_UNDEF;
13389 defspec = SvPV(ST(1),n_a);
13390 dfs_utf8 = SvUTF8(ST(1));
13392 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13393 ST(0) = sv_newmortal();
13394 if (rslt != NULL) {
13395 sv_usepvn(ST(0),rslt,strlen(rslt));
13404 vmsify_fromperl(pTHX_ CV *cv)
13411 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13412 utf8_fl = SvUTF8(ST(0));
13413 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13414 ST(0) = sv_newmortal();
13415 if (vmsified != NULL) {
13416 sv_usepvn(ST(0),vmsified,strlen(vmsified));
13425 unixify_fromperl(pTHX_ CV *cv)
13432 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13433 utf8_fl = SvUTF8(ST(0));
13434 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13435 ST(0) = sv_newmortal();
13436 if (unixified != NULL) {
13437 sv_usepvn(ST(0),unixified,strlen(unixified));
13446 fileify_fromperl(pTHX_ CV *cv)
13453 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13454 utf8_fl = SvUTF8(ST(0));
13455 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13456 ST(0) = sv_newmortal();
13457 if (fileified != NULL) {
13458 sv_usepvn(ST(0),fileified,strlen(fileified));
13467 pathify_fromperl(pTHX_ CV *cv)
13474 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13475 utf8_fl = SvUTF8(ST(0));
13476 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13477 ST(0) = sv_newmortal();
13478 if (pathified != NULL) {
13479 sv_usepvn(ST(0),pathified,strlen(pathified));
13488 vmspath_fromperl(pTHX_ CV *cv)
13495 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13496 utf8_fl = SvUTF8(ST(0));
13497 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13498 ST(0) = sv_newmortal();
13499 if (vmspath != NULL) {
13500 sv_usepvn(ST(0),vmspath,strlen(vmspath));
13509 unixpath_fromperl(pTHX_ CV *cv)
13516 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13517 utf8_fl = SvUTF8(ST(0));
13518 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13519 ST(0) = sv_newmortal();
13520 if (unixpath != NULL) {
13521 sv_usepvn(ST(0),unixpath,strlen(unixpath));
13530 candelete_fromperl(pTHX_ CV *cv)
13538 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13540 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13541 Newx(fspec, VMS_MAXRSS, char);
13542 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13543 if (SvTYPE(mysv) == SVt_PVGV) {
13544 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13545 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13553 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13554 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13561 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13567 rmscopy_fromperl(pTHX_ CV *cv)
13570 char *inspec, *outspec, *inp, *outp;
13572 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13573 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13574 unsigned long int sts;
13579 if (items < 2 || items > 3)
13580 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13582 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13583 Newx(inspec, VMS_MAXRSS, char);
13584 if (SvTYPE(mysv) == SVt_PVGV) {
13585 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13586 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13587 ST(0) = sv_2mortal(newSViv(0));
13594 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13595 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13596 ST(0) = sv_2mortal(newSViv(0));
13601 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13602 Newx(outspec, VMS_MAXRSS, char);
13603 if (SvTYPE(mysv) == SVt_PVGV) {
13604 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13605 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13606 ST(0) = sv_2mortal(newSViv(0));
13614 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13615 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13616 ST(0) = sv_2mortal(newSViv(0));
13622 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13624 ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
13630 /* The mod2fname is limited to shorter filenames by design, so it should
13631 * not be modified to support longer EFS pathnames
13634 mod2fname(pTHX_ CV *cv)
13637 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13638 workbuff[NAM$C_MAXRSS*1 + 1];
13639 int total_namelen = 3, counter, num_entries;
13640 /* ODS-5 ups this, but we want to be consistent, so... */
13641 int max_name_len = 39;
13642 AV *in_array = (AV *)SvRV(ST(0));
13644 num_entries = av_len(in_array);
13646 /* All the names start with PL_. */
13647 strcpy(ultimate_name, "PL_");
13649 /* Clean up our working buffer */
13650 Zero(work_name, sizeof(work_name), char);
13652 /* Run through the entries and build up a working name */
13653 for(counter = 0; counter <= num_entries; counter++) {
13654 /* If it's not the first name then tack on a __ */
13656 strcat(work_name, "__");
13658 strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13661 /* Check to see if we actually have to bother...*/
13662 if (strlen(work_name) + 3 <= max_name_len) {
13663 strcat(ultimate_name, work_name);
13665 /* It's too darned big, so we need to go strip. We use the same */
13666 /* algorithm as xsubpp does. First, strip out doubled __ */
13667 char *source, *dest, last;
13670 for (source = work_name; *source; source++) {
13671 if (last == *source && last == '_') {
13677 /* Go put it back */
13678 strcpy(work_name, workbuff);
13679 /* Is it still too big? */
13680 if (strlen(work_name) + 3 > max_name_len) {
13681 /* Strip duplicate letters */
13684 for (source = work_name; *source; source++) {
13685 if (last == toupper(*source)) {
13689 last = toupper(*source);
13691 strcpy(work_name, workbuff);
13694 /* Is it *still* too big? */
13695 if (strlen(work_name) + 3 > max_name_len) {
13696 /* Too bad, we truncate */
13697 work_name[max_name_len - 2] = 0;
13699 strcat(ultimate_name, work_name);
13702 /* Okay, return it */
13703 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13708 hushexit_fromperl(pTHX_ CV *cv)
13713 VMSISH_HUSHED = SvTRUE(ST(0));
13715 ST(0) = boolSV(VMSISH_HUSHED);
13721 Perl_vms_start_glob
13722 (pTHX_ SV *tmpglob,
13726 struct vs_str_st *rslt;
13730 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13733 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13734 struct dsc$descriptor_vs rsdsc;
13735 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13736 unsigned long hasver = 0, isunix = 0;
13737 unsigned long int lff_flags = 0;
13739 int vms_old_glob = 1;
13741 if (!SvOK(tmpglob)) {
13742 SETERRNO(ENOENT,RMS$_FNF);
13746 vms_old_glob = !decc_filename_unix_report;
13748 #ifdef VMS_LONGNAME_SUPPORT
13749 lff_flags = LIB$M_FIL_LONG_NAMES;
13751 /* The Newx macro will not allow me to assign a smaller array
13752 * to the rslt pointer, so we will assign it to the begin char pointer
13753 * and then copy the value into the rslt pointer.
13755 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13756 rslt = (struct vs_str_st *)begin;
13758 rstr = &rslt->str[0];
13759 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13760 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13761 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13762 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13764 Newx(vmsspec, VMS_MAXRSS, char);
13766 /* We could find out if there's an explicit dev/dir or version
13767 by peeking into lib$find_file's internal context at
13768 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13769 but that's unsupported, so I don't want to do it now and
13770 have it bite someone in the future. */
13771 /* Fix-me: vms_split_path() is the only way to do this, the
13772 existing method will fail with many legal EFS or UNIX specifications
13775 cp = SvPV(tmpglob,i);
13778 if (cp[i] == ';') hasver = 1;
13779 if (cp[i] == '.') {
13780 if (sts) hasver = 1;
13783 if (cp[i] == '/') {
13784 hasdir = isunix = 1;
13787 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13793 /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13794 if ((hasdir == 0) && decc_filename_unix_report) {
13798 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13799 char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13800 int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13806 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13807 if (!stat_sts && S_ISDIR(st.st_mode)) {
13809 const char * fname;
13812 /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13813 /* path delimiter of ':>]', if so, then the old behavior has */
13814 /* obviously been specificially requested */
13816 fname = SvPVX_const(tmpglob);
13817 fname_len = strlen(fname);
13818 vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13819 if (vms_old_glob || (vms_dir != NULL)) {
13820 wilddsc.dsc$a_pointer = tovmspath_utf8(
13821 SvPVX(tmpglob),vmsspec,NULL);
13822 ok = (wilddsc.dsc$a_pointer != NULL);
13823 /* maybe passed 'foo' rather than '[.foo]', thus not
13827 /* Operate just on the directory, the special stat/fstat for */
13828 /* leaves the fileified specification in the st_devnam */
13830 wilddsc.dsc$a_pointer = st.st_devnam;
13835 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13836 ok = (wilddsc.dsc$a_pointer != NULL);
13839 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13841 /* If not extended character set, replace ? with % */
13842 /* With extended character set, ? is a wildcard single character */
13843 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13846 if (!decc_efs_case_preserve)
13848 } else if (*cp == '%') {
13850 } else if (*cp == '*') {
13856 wv_sts = vms_split_path(
13857 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13858 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13859 &wvs_spec, &wvs_len);
13868 while (ok && $VMS_STATUS_SUCCESS(sts)) {
13869 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13870 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13874 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13875 &dfltdsc,NULL,&rms_sts,&lff_flags);
13876 if (!$VMS_STATUS_SUCCESS(sts))
13879 /* with varying string, 1st word of buffer contains result length */
13880 rstr[rslt->length] = '\0';
13882 /* Find where all the components are */
13883 v_sts = vms_split_path
13898 /* If no version on input, truncate the version on output */
13899 if (!hasver && (vs_len > 0)) {
13906 /* In Unix report mode, remove the ".dir;1" from the name */
13907 /* if it is a real directory */
13908 if (decc_filename_unix_report || decc_efs_charset) {
13909 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13913 ret_sts = flex_lstat(rstr, &statbuf);
13914 if ((ret_sts == 0) &&
13915 S_ISDIR(statbuf.st_mode)) {
13922 /* No version & a null extension on UNIX handling */
13923 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13929 if (!decc_efs_case_preserve) {
13930 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13933 /* Find File treats a Null extension as return all extensions */
13934 /* This is contrary to Perl expectations */
13936 if (wildstar || wildquery || vms_old_glob) {
13937 /* really need to see if the returned file name matched */
13938 /* but for now will assume that it matches */
13941 /* Exact Match requested */
13942 /* How are directories handled? - like a file */
13943 if ((e_len == we_len) && (n_len == wn_len)) {
13947 t1 = strncmp(e_spec, we_spec, e_len);
13951 t1 = strncmp(n_spec, we_spec, n_len);
13962 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13966 /* Start with the name */
13969 strcat(begin,"\n");
13970 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13973 if (cxt) (void)lib$find_file_end(&cxt);
13976 /* Be POSIXish: return the input pattern when no matches */
13977 strcpy(rstr,SvPVX(tmpglob));
13979 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13982 if (ok && sts != RMS$_NMF &&
13983 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13986 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13988 PerlIO_close(tmpfp);
13992 PerlIO_rewind(tmpfp);
13993 IoTYPE(io) = IoTYPE_RDONLY;
13994 IoIFP(io) = fp = tmpfp;
13995 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
14005 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
14009 unixrealpath_fromperl(pTHX_ CV *cv)
14012 char *fspec, *rslt_spec, *rslt;
14015 if (!items || items != 1)
14016 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
14018 fspec = SvPV(ST(0),n_a);
14019 if (!fspec || !*fspec) XSRETURN_UNDEF;
14021 Newx(rslt_spec, VMS_MAXRSS + 1, char);
14022 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
14024 ST(0) = sv_newmortal();
14026 sv_usepvn(ST(0),rslt,strlen(rslt));
14028 Safefree(rslt_spec);
14033 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
14037 vmsrealpath_fromperl(pTHX_ CV *cv)
14040 char *fspec, *rslt_spec, *rslt;
14043 if (!items || items != 1)
14044 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
14046 fspec = SvPV(ST(0),n_a);
14047 if (!fspec || !*fspec) XSRETURN_UNDEF;
14049 Newx(rslt_spec, VMS_MAXRSS + 1, char);
14050 rslt = do_vms_realname(fspec, rslt_spec, NULL);
14052 ST(0) = sv_newmortal();
14054 sv_usepvn(ST(0),rslt,strlen(rslt));
14056 Safefree(rslt_spec);
14062 * A thin wrapper around decc$symlink to make sure we follow the
14063 * standard and do not create a symlink with a zero-length name.
14065 * Also in ODS-2 mode, existing tests assume that the link target
14066 * will be converted to UNIX format.
14068 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
14069 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
14070 if (!link_name || !*link_name) {
14071 SETERRNO(ENOENT, SS$_NOSUCHFILE);
14075 if (decc_efs_charset) {
14076 return symlink(contents, link_name);
14081 /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
14082 /* because in order to work, the symlink target must be in UNIX format */
14084 /* As symbolic links can hold things other than files, we will only do */
14085 /* the conversion in in ODS-2 mode */
14087 utarget = PerlMem_malloc(VMS_MAXRSS + 1);
14088 if (int_tounixspec(contents, utarget, NULL) == NULL) {
14090 /* This should not fail, as an untranslatable filename */
14091 /* should be passed through */
14092 utarget = (char *)contents;
14094 sts = symlink(utarget, link_name);
14095 PerlMem_free(utarget);
14102 #endif /* HAS_SYMLINK */
14104 int do_vms_case_tolerant(void);
14107 case_tolerant_process_fromperl(pTHX_ CV *cv)
14110 ST(0) = boolSV(do_vms_case_tolerant());
14114 #ifdef USE_ITHREADS
14117 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
14118 struct interp_intern *dst)
14120 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
14122 memcpy(dst,src,sizeof(struct interp_intern));
14128 Perl_sys_intern_clear(pTHX)
14133 Perl_sys_intern_init(pTHX)
14135 unsigned int ix = RAND_MAX;
14140 MY_POSIX_EXIT = vms_posix_exit;
14143 MY_INV_RAND_MAX = 1./x;
14147 init_os_extras(void)
14150 char* file = __FILE__;
14151 if (decc_disable_to_vms_logname_translation) {
14152 no_translate_barewords = TRUE;
14154 no_translate_barewords = FALSE;
14157 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
14158 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
14159 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
14160 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
14161 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
14162 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
14163 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
14164 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
14165 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
14166 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
14167 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
14168 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
14169 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
14170 newXSproto("VMS::Filespec::case_tolerant_process",
14171 case_tolerant_process_fromperl,file,"");
14173 store_pipelocs(aTHX); /* will redo any earlier attempts */
14178 #if __CRTL_VER == 80200000
14179 /* This missed getting in to the DECC SDK for 8.2 */
14180 char *realpath(const char *file_name, char * resolved_name, ...);
14183 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
14184 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
14185 * The perl fallback routine to provide realpath() is not as efficient
14189 /* Hack, use old stat() as fastest way of getting ino_t and device */
14190 int decc$stat(const char *name, void * statbuf);
14191 #if !defined(__VAX) && __CRTL_VER >= 80200000
14192 int decc$lstat(const char *name, void * statbuf);
14194 #define decc$lstat decc$stat
14198 /* Realpath is fragile. In 8.3 it does not work if the feature
14199 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
14200 * links are implemented in RMS, not the CRTL. It also can fail if the
14201 * user does not have read/execute access to some of the directories.
14202 * So in order for Do What I Mean mode to work, if realpath() fails,
14203 * fall back to looking up the filename by the device name and FID.
14206 int vms_fid_to_name(char * outname, int outlen,
14207 const char * name, int lstat_flag, mode_t * mode)
14209 #pragma message save
14210 #pragma message disable MISALGNDSTRCT
14211 #pragma message disable MISALGNDMEM
14212 #pragma member_alignment save
14213 #pragma nomember_alignment
14216 unsigned short st_ino[3];
14217 unsigned short old_st_mode;
14218 unsigned long padl[30]; /* plenty of room */
14220 #pragma message restore
14221 #pragma member_alignment restore
14224 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14225 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14230 /* Need to follow the mostly the same rules as flex_stat_int, or we may get
14231 * unexpected answers
14234 fileified = PerlMem_malloc(VMS_MAXRSS);
14235 if (fileified == NULL)
14236 _ckvmssts_noperl(SS$_INSFMEM);
14238 temp_fspec = PerlMem_malloc(VMS_MAXRSS);
14239 if (temp_fspec == NULL)
14240 _ckvmssts_noperl(SS$_INSFMEM);
14243 /* First need to try as a directory */
14244 ret_spec = int_tovmspath(name, temp_fspec, NULL);
14245 if (ret_spec != NULL) {
14246 ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
14247 if (ret_spec != NULL) {
14248 if (lstat_flag == 0)
14249 sts = decc$stat(fileified, &statbuf);
14251 sts = decc$lstat(fileified, &statbuf);
14255 /* Then as a VMS file spec */
14257 ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
14258 if (ret_spec != NULL) {
14259 if (lstat_flag == 0) {
14260 sts = decc$stat(temp_fspec, &statbuf);
14262 sts = decc$lstat(temp_fspec, &statbuf);
14268 /* Next try - allow multiple dots with out EFS CHARSET */
14269 /* The CRTL stat() falls down hard on multi-dot filenames in unix
14270 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
14271 * enable it if it isn't already.
14273 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14274 if (!decc_efs_charset && (decc_efs_charset_index > 0))
14275 decc$feature_set_value(decc_efs_charset_index, 1, 1);
14277 ret_spec = int_tovmspath(name, temp_fspec, NULL);
14278 if (lstat_flag == 0) {
14279 sts = decc$stat(name, &statbuf);
14281 sts = decc$lstat(name, &statbuf);
14283 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14284 if (!decc_efs_charset && (decc_efs_charset_index > 0))
14285 decc$feature_set_value(decc_efs_charset_index, 1, 0);
14290 /* and then because the Perl Unix to VMS conversion is not perfect */
14291 /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
14292 /* characters from filenames so we need to try it as-is */
14294 if (lstat_flag == 0) {
14295 sts = decc$stat(name, &statbuf);
14297 sts = decc$lstat(name, &statbuf);
14304 dvidsc.dsc$a_pointer=statbuf.st_dev;
14305 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
14307 specdsc.dsc$a_pointer = outname;
14308 specdsc.dsc$w_length = outlen-1;
14310 vms_sts = lib$fid_to_name
14311 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
14312 if ($VMS_STATUS_SUCCESS(vms_sts)) {
14313 outname[specdsc.dsc$w_length] = 0;
14315 /* Return the mode */
14317 *mode = statbuf.old_st_mode;
14328 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
14331 char * rslt = NULL;
14334 if (decc_posix_compliant_pathnames > 0 ) {
14335 /* realpath currently only works if posix compliant pathnames are
14336 * enabled. It may start working when they are not, but in that
14337 * case we still want the fallback behavior for backwards compatibility
14339 rslt = realpath(filespec, outbuf);
14343 if (rslt == NULL) {
14345 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14346 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14350 /* Fall back to fid_to_name */
14352 Newx(vms_spec, VMS_MAXRSS + 1, char);
14354 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
14358 /* Now need to trim the version off */
14359 sts = vms_split_path
14379 /* Trim off the version */
14380 int file_len = v_len + r_len + d_len + n_len + e_len;
14381 vms_spec[file_len] = 0;
14383 /* Trim off the .DIR if this is a directory */
14384 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
14385 if (S_ISDIR(my_mode)) {
14391 /* Drop NULL extensions on UNIX file specification */
14392 if ((e_len == 1) && decc_readdir_dropdotnotype) {
14397 /* The result is expected to be in UNIX format */
14398 rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14400 /* Downcase if input had any lower case letters and
14401 * case preservation is not in effect.
14403 if (!decc_efs_case_preserve) {
14404 for (cp = filespec; *cp; cp++)
14405 if (islower(*cp)) { haslower = 1; break; }
14407 if (haslower) __mystrtolower(rslt);
14412 /* Now for some hacks to deal with backwards and forward */
14414 if (!decc_efs_charset) {
14416 /* 1. ODS-2 mode wants to do a syntax only translation */
14417 rslt = int_rmsexpand(filespec, outbuf,
14418 NULL, 0, NULL, utf8_fl);
14421 if (decc_filename_unix_report) {
14423 char * vms_dir_name;
14426 /* 2. ODS-5 / UNIX report mode should return a failure */
14427 /* if the parent directory also does not exist */
14428 /* Otherwise, get the real path for the parent */
14429 /* and add the child to it.
14431 /* basename / dirname only available for VMS 7.0+ */
14432 /* So we may need to implement them as common routines */
14434 Newx(dir_name, VMS_MAXRSS + 1, char);
14435 Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14436 dir_name[0] = '\0';
14439 /* First try a VMS parse */
14440 sts = vms_split_path
14458 int dir_len = v_len + r_len + d_len + n_len;
14460 strncpy(dir_name, filespec, dir_len);
14461 dir_name[dir_len] = '\0';
14462 file_name = (char *)&filespec[dir_len + 1];
14465 /* This must be UNIX */
14468 tchar = strrchr(filespec, '/');
14470 if (tchar != NULL) {
14471 int dir_len = tchar - filespec;
14472 strncpy(dir_name, filespec, dir_len);
14473 dir_name[dir_len] = '\0';
14474 file_name = (char *) &filespec[dir_len + 1];
14478 /* Dir name is defaulted */
14479 if (dir_name[0] == 0) {
14481 dir_name[1] = '\0';
14484 /* Need realpath for the directory */
14485 sts = vms_fid_to_name(vms_dir_name,
14487 dir_name, 0, NULL);
14490 /* Now need to pathify it.
14491 char *tdir = int_pathify_dirspec(vms_dir_name,
14494 /* And now add the original filespec to it */
14495 if (file_name != NULL) {
14496 strcat(outbuf, file_name);
14500 Safefree(vms_dir_name);
14501 Safefree(dir_name);
14505 Safefree(vms_spec);
14511 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14514 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14515 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14518 /* Fall back to fid_to_name */
14520 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
14527 /* Now need to trim the version off */
14528 sts = vms_split_path
14548 /* Trim off the version */
14549 int file_len = v_len + r_len + d_len + n_len + e_len;
14550 outbuf[file_len] = 0;
14552 /* Downcase if input had any lower case letters and
14553 * case preservation is not in effect.
14555 if (!decc_efs_case_preserve) {
14556 for (cp = filespec; *cp; cp++)
14557 if (islower(*cp)) { haslower = 1; break; }
14559 if (haslower) __mystrtolower(outbuf);
14568 /* External entry points */
14569 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14570 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14572 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14573 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14575 /* case_tolerant */
14577 /*{{{int do_vms_case_tolerant(void)*/
14578 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14579 * controlled by a process setting.
14581 int do_vms_case_tolerant(void)
14583 return vms_process_case_tolerant;
14586 /* External entry points */
14587 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14588 int Perl_vms_case_tolerant(void)
14589 { return do_vms_case_tolerant(); }
14591 int Perl_vms_case_tolerant(void)
14592 { return vms_process_case_tolerant; }
14596 /* Start of DECC RTL Feature handling */
14598 static int sys_trnlnm
14599 (const char * logname,
14603 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14604 const unsigned long attr = LNM$M_CASE_BLIND;
14605 struct dsc$descriptor_s name_dsc;
14607 unsigned short result;
14608 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14611 name_dsc.dsc$w_length = strlen(logname);
14612 name_dsc.dsc$a_pointer = (char *)logname;
14613 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14614 name_dsc.dsc$b_class = DSC$K_CLASS_S;
14616 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14618 if ($VMS_STATUS_SUCCESS(status)) {
14620 /* Null terminate and return the string */
14621 /*--------------------------------------*/
14628 static int sys_crelnm
14629 (const char * logname,
14630 const char * value)
14633 const char * proc_table = "LNM$PROCESS_TABLE";
14634 struct dsc$descriptor_s proc_table_dsc;
14635 struct dsc$descriptor_s logname_dsc;
14636 struct itmlst_3 item_list[2];
14638 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14639 proc_table_dsc.dsc$w_length = strlen(proc_table);
14640 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14641 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14643 logname_dsc.dsc$a_pointer = (char *) logname;
14644 logname_dsc.dsc$w_length = strlen(logname);
14645 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14646 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14648 item_list[0].buflen = strlen(value);
14649 item_list[0].itmcode = LNM$_STRING;
14650 item_list[0].bufadr = (char *)value;
14651 item_list[0].retlen = NULL;
14653 item_list[1].buflen = 0;
14654 item_list[1].itmcode = 0;
14656 ret_val = sys$crelnm
14658 (const struct dsc$descriptor_s *)&proc_table_dsc,
14659 (const struct dsc$descriptor_s *)&logname_dsc,
14661 (const struct item_list_3 *) item_list);
14666 /* C RTL Feature settings */
14668 static int set_features
14669 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
14670 int (* cli_routine)(void), /* Not documented */
14671 void *image_info) /* Not documented */
14677 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14678 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14679 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14680 unsigned long case_perm;
14681 unsigned long case_image;
14684 /* Allow an exception to bring Perl into the VMS debugger */
14685 vms_debug_on_exception = 0;
14686 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14687 if ($VMS_STATUS_SUCCESS(status)) {
14688 val_str[0] = _toupper(val_str[0]);
14689 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14690 vms_debug_on_exception = 1;
14692 vms_debug_on_exception = 0;
14695 /* Debug unix/vms file translation routines */
14696 vms_debug_fileify = 0;
14697 status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14698 if ($VMS_STATUS_SUCCESS(status)) {
14699 val_str[0] = _toupper(val_str[0]);
14700 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14701 vms_debug_fileify = 1;
14703 vms_debug_fileify = 0;
14707 /* Historically PERL has been doing vmsify / stat differently than */
14708 /* the CRTL. In particular, under some conditions the CRTL will */
14709 /* remove some illegal characters like spaces from filenames */
14710 /* resulting in some differences. The stat()/lstat() wrapper has */
14711 /* been reporting such file names as invalid and fails to stat them */
14712 /* fixing this bug so that stat()/lstat() accept these like the */
14713 /* CRTL does will result in several tests failing. */
14714 /* This should really be fixed, but for now, set up a feature to */
14715 /* enable it so that the impact can be studied. */
14716 vms_bug_stat_filename = 0;
14717 status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14718 if ($VMS_STATUS_SUCCESS(status)) {
14719 val_str[0] = _toupper(val_str[0]);
14720 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14721 vms_bug_stat_filename = 1;
14723 vms_bug_stat_filename = 0;
14727 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14728 vms_vtf7_filenames = 0;
14729 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14730 if ($VMS_STATUS_SUCCESS(status)) {
14731 val_str[0] = _toupper(val_str[0]);
14732 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14733 vms_vtf7_filenames = 1;
14735 vms_vtf7_filenames = 0;
14738 /* unlink all versions on unlink() or rename() */
14739 vms_unlink_all_versions = 0;
14740 status = sys_trnlnm
14741 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14742 if ($VMS_STATUS_SUCCESS(status)) {
14743 val_str[0] = _toupper(val_str[0]);
14744 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14745 vms_unlink_all_versions = 1;
14747 vms_unlink_all_versions = 0;
14750 /* Dectect running under GNV Bash or other UNIX like shell */
14751 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14752 gnv_unix_shell = 0;
14753 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14754 if ($VMS_STATUS_SUCCESS(status)) {
14755 gnv_unix_shell = 1;
14756 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14757 set_feature_default("DECC$EFS_CHARSET", 1);
14758 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14759 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14760 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14761 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14762 vms_unlink_all_versions = 1;
14763 vms_posix_exit = 1;
14767 /* hacks to see if known bugs are still present for testing */
14769 /* PCP mode requires creating /dev/null special device file */
14770 decc_bug_devnull = 0;
14771 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14772 if ($VMS_STATUS_SUCCESS(status)) {
14773 val_str[0] = _toupper(val_str[0]);
14774 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14775 decc_bug_devnull = 1;
14777 decc_bug_devnull = 0;
14780 /* UNIX directory names with no paths are broken in a lot of places */
14781 decc_dir_barename = 1;
14782 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14783 if ($VMS_STATUS_SUCCESS(status)) {
14784 val_str[0] = _toupper(val_str[0]);
14785 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14786 decc_dir_barename = 1;
14788 decc_dir_barename = 0;
14791 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14792 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14794 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14795 if (decc_disable_to_vms_logname_translation < 0)
14796 decc_disable_to_vms_logname_translation = 0;
14799 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14801 decc_efs_case_preserve = decc$feature_get_value(s, 1);
14802 if (decc_efs_case_preserve < 0)
14803 decc_efs_case_preserve = 0;
14806 s = decc$feature_get_index("DECC$EFS_CHARSET");
14807 decc_efs_charset_index = s;
14809 decc_efs_charset = decc$feature_get_value(s, 1);
14810 if (decc_efs_charset < 0)
14811 decc_efs_charset = 0;
14814 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14816 decc_filename_unix_report = decc$feature_get_value(s, 1);
14817 if (decc_filename_unix_report > 0) {
14818 decc_filename_unix_report = 1;
14819 vms_posix_exit = 1;
14822 decc_filename_unix_report = 0;
14825 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14827 decc_filename_unix_only = decc$feature_get_value(s, 1);
14828 if (decc_filename_unix_only > 0) {
14829 decc_filename_unix_only = 1;
14832 decc_filename_unix_only = 0;
14836 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14838 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14839 if (decc_filename_unix_no_version < 0)
14840 decc_filename_unix_no_version = 0;
14843 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14845 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14846 if (decc_readdir_dropdotnotype < 0)
14847 decc_readdir_dropdotnotype = 0;
14850 #if __CRTL_VER >= 80200000
14851 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14853 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14854 if (decc_posix_compliant_pathnames < 0)
14855 decc_posix_compliant_pathnames = 0;
14856 if (decc_posix_compliant_pathnames > 4)
14857 decc_posix_compliant_pathnames = 0;
14862 status = sys_trnlnm
14863 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", 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_disable_to_vms_logname_translation = 1;
14872 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", 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_efs_case_preserve = 1;
14881 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14882 if ($VMS_STATUS_SUCCESS(status)) {
14883 val_str[0] = _toupper(val_str[0]);
14884 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14885 decc_filename_unix_report = 1;
14888 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14889 if ($VMS_STATUS_SUCCESS(status)) {
14890 val_str[0] = _toupper(val_str[0]);
14891 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14892 decc_filename_unix_only = 1;
14893 decc_filename_unix_report = 1;
14896 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14897 if ($VMS_STATUS_SUCCESS(status)) {
14898 val_str[0] = _toupper(val_str[0]);
14899 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14900 decc_filename_unix_no_version = 1;
14903 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14904 if ($VMS_STATUS_SUCCESS(status)) {
14905 val_str[0] = _toupper(val_str[0]);
14906 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14907 decc_readdir_dropdotnotype = 1;
14912 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14914 /* Report true case tolerance */
14915 /*----------------------------*/
14916 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14917 if (!$VMS_STATUS_SUCCESS(status))
14918 case_perm = PPROP$K_CASE_BLIND;
14919 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14920 if (!$VMS_STATUS_SUCCESS(status))
14921 case_image = PPROP$K_CASE_BLIND;
14922 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14923 (case_image == PPROP$K_CASE_SENSITIVE))
14924 vms_process_case_tolerant = 0;
14928 /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
14929 /* for strict backward compatibilty */
14930 status = sys_trnlnm
14931 ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14932 if ($VMS_STATUS_SUCCESS(status)) {
14933 val_str[0] = _toupper(val_str[0]);
14934 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14935 vms_posix_exit = 1;
14937 vms_posix_exit = 0;
14941 /* CRTL can be initialized past this point, but not before. */
14942 /* DECC$CRTL_INIT(); */
14949 #pragma extern_model save
14950 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14951 const __align (LONGWORD) int spare[8] = {0};
14953 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14954 #if __DECC_VER >= 60560002
14955 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14957 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14959 #endif /* __DECC */
14961 const long vms_cc_features = (const long)set_features;
14964 ** Force a reference to LIB$INITIALIZE to ensure it
14965 ** exists in the image.
14967 int lib$initialize(void);
14969 #pragma extern_model strict_refdef
14971 int lib_init_ref = (int) lib$initialize;
14974 #pragma extern_model restore