3 * VMS-specific routines for perl5
5 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
6 * 2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
8 * You may distribute under the terms of either the GNU General Public
9 * License or the Artistic License, as specified in the README file.
11 * Please see Changes*.* or the Perl Repository Browser for revision history.
15 * Yet small as was their hunted band
16 * still fell and fearless was each hand,
17 * and strong deeds they wrought yet oft,
18 * and loved the woods, whose ways more soft
19 * them seemed than thralls of that black throne
20 * to live and languish in halls of stone.
21 * "The Lay of Leithian", Canto II, lines 135-40
23 * [p.162 of _The Lays of Beleriand_]
32 #include <climsgdef.h>
43 #include <libclidef.h>
45 #include <lib$routines.h>
49 #if __CRTL_VER >= 70301000 && !defined(__VAX)
59 #include <str$routines.h>
66 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
68 #define NO_EFN EFN$C_ENF
73 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
74 int decc$feature_get_index(const char *name);
75 char* decc$feature_get_name(int index);
76 int decc$feature_get_value(int index, int mode);
77 int decc$feature_set_value(int index, int mode, int value);
82 #pragma member_alignment save
83 #pragma nomember_alignment longword
88 unsigned short * retadr;
90 #pragma member_alignment restore
92 /* More specific prototype than in starlet_c.h makes programming errors
100 const struct dsc$descriptor_s * devnam,
101 const struct item_list_3 * itmlst,
103 void * (astadr)(unsigned long),
108 #ifdef sys$get_security
109 #undef sys$get_security
111 (const struct dsc$descriptor_s * clsnam,
112 const struct dsc$descriptor_s * objnam,
113 const unsigned int *objhan,
115 const struct item_list_3 * itmlst,
116 unsigned int * contxt,
117 const unsigned int * acmode);
120 #ifdef sys$set_security
121 #undef sys$set_security
123 (const struct dsc$descriptor_s * clsnam,
124 const struct dsc$descriptor_s * objnam,
125 const unsigned int *objhan,
127 const struct item_list_3 * itmlst,
128 unsigned int * contxt,
129 const unsigned int * acmode);
132 #ifdef lib$find_image_symbol
133 #undef lib$find_image_symbol
134 int lib$find_image_symbol
135 (const struct dsc$descriptor_s * imgname,
136 const struct dsc$descriptor_s * symname,
138 const struct dsc$descriptor_s * defspec,
142 #ifdef lib$rename_file
143 #undef lib$rename_file
145 (const struct dsc$descriptor_s * old_file_dsc,
146 const struct dsc$descriptor_s * new_file_dsc,
147 const struct dsc$descriptor_s * default_file_dsc,
148 const struct dsc$descriptor_s * related_file_dsc,
149 const unsigned long * flags,
150 void * (success)(const struct dsc$descriptor_s * old_dsc,
151 const struct dsc$descriptor_s * new_dsc,
153 void * (error)(const struct dsc$descriptor_s * old_dsc,
154 const struct dsc$descriptor_s * new_dsc,
157 const int * error_src,
158 const void * usr_arg),
159 int (confirm)(const struct dsc$descriptor_s * old_dsc,
160 const struct dsc$descriptor_s * new_dsc,
161 const void * old_fab,
162 const void * usr_arg),
164 struct dsc$descriptor_s * old_result_name_dsc,
165 struct dsc$descriptor_s * new_result_name_dsc,
166 unsigned long * file_scan_context);
169 #if __CRTL_VER >= 70300000 && !defined(__VAX)
171 static int set_feature_default(const char *name, int value)
176 index = decc$feature_get_index(name);
178 status = decc$feature_set_value(index, 1, value);
179 if (index == -1 || (status == -1)) {
183 status = decc$feature_get_value(index, 1);
184 if (status != value) {
192 /* Older versions of ssdef.h don't have these */
193 #ifndef SS$_INVFILFOROP
194 # define SS$_INVFILFOROP 3930
196 #ifndef SS$_NOSUCHOBJECT
197 # define SS$_NOSUCHOBJECT 2696
200 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
201 #define PERLIO_NOT_STDIO 0
203 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
204 * code below needs to get to the underlying CRTL routines. */
205 #define DONT_MASK_RTL_CALLS
209 /* Anticipating future expansion in lexical warnings . . . */
210 #ifndef WARN_INTERNAL
211 # define WARN_INTERNAL WARN_MISC
214 #ifdef VMS_LONGNAME_SUPPORT
215 #include <libfildef.h>
218 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
219 # define RTL_USES_UTC 1
222 /* Routine to create a decterm for use with the Perl debugger */
223 /* No headers, this information was found in the Programming Concepts Manual */
225 static int (*decw_term_port)
226 (const struct dsc$descriptor_s * display,
227 const struct dsc$descriptor_s * setup_file,
228 const struct dsc$descriptor_s * customization,
229 struct dsc$descriptor_s * result_device_name,
230 unsigned short * result_device_name_length,
233 void * char_change_buffer) = 0;
235 /* gcc's header files don't #define direct access macros
236 * corresponding to VAXC's variant structs */
238 # define uic$v_format uic$r_uic_form.uic$v_format
239 # define uic$v_group uic$r_uic_form.uic$v_group
240 # define uic$v_member uic$r_uic_form.uic$v_member
241 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
242 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
243 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
244 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
247 #if defined(NEED_AN_H_ERRNO)
252 #pragma message disable pragma
253 #pragma member_alignment save
254 #pragma nomember_alignment longword
256 #pragma message disable misalgndmem
259 unsigned short int buflen;
260 unsigned short int itmcode;
262 unsigned short int *retlen;
265 struct filescan_itmlst_2 {
266 unsigned short length;
267 unsigned short itmcode;
272 unsigned short length;
277 #pragma message restore
278 #pragma member_alignment restore
281 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
282 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
283 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
284 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
285 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
286 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
287 #define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
288 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
289 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
290 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
291 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
292 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
294 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
295 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
296 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
297 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
299 static char * int_rmsexpand_vms(
300 const char * filespec, char * outbuf, unsigned opts);
301 static char * int_rmsexpand_tovms(
302 const char * filespec, char * outbuf, unsigned opts);
303 static char *int_tovmsspec
304 (const char *path, char *buf, int dir_flag, int * utf8_flag);
305 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
306 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
308 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
309 #define PERL_LNM_MAX_ALLOWED_INDEX 127
311 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
312 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
315 #define PERL_LNM_MAX_ITER 10
317 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
318 #if __CRTL_VER >= 70302000 && !defined(__VAX)
319 #define MAX_DCL_SYMBOL (8192)
320 #define MAX_DCL_LINE_LENGTH (4096 - 4)
322 #define MAX_DCL_SYMBOL (1024)
323 #define MAX_DCL_LINE_LENGTH (1024 - 4)
326 static char *__mystrtolower(char *str)
328 if (str) for (; *str; ++str) *str= tolower(*str);
332 static struct dsc$descriptor_s fildevdsc =
333 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
334 static struct dsc$descriptor_s crtlenvdsc =
335 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
336 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
337 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
338 static struct dsc$descriptor_s **env_tables = defenv;
339 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
341 /* True if we shouldn't treat barewords as logicals during directory */
343 static int no_translate_barewords;
346 static int tz_updated = 1;
349 /* DECC Features that may need to affect how Perl interprets
350 * displays filename information
352 static int decc_disable_to_vms_logname_translation = 1;
353 static int decc_disable_posix_root = 1;
354 int decc_efs_case_preserve = 0;
355 static int decc_efs_charset = 0;
356 static int decc_efs_charset_index = -1;
357 static int decc_filename_unix_no_version = 0;
358 static int decc_filename_unix_only = 0;
359 int decc_filename_unix_report = 0;
360 int decc_posix_compliant_pathnames = 0;
361 int decc_readdir_dropdotnotype = 0;
362 static int vms_process_case_tolerant = 1;
363 int vms_vtf7_filenames = 0;
364 int gnv_unix_shell = 0;
365 static int vms_unlink_all_versions = 0;
366 static int vms_posix_exit = 0;
368 /* bug workarounds if needed */
369 int decc_bug_devnull = 1;
370 int decc_dir_barename = 0;
371 int vms_bug_stat_filename = 0;
373 static int vms_debug_on_exception = 0;
374 static int vms_debug_fileify = 0;
376 /* Simple logical name translation */
377 static int simple_trnlnm
378 (const char * logname,
382 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
383 const unsigned long attr = LNM$M_CASE_BLIND;
384 struct dsc$descriptor_s name_dsc;
386 unsigned short result;
387 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
390 name_dsc.dsc$w_length = strlen(logname);
391 name_dsc.dsc$a_pointer = (char *)logname;
392 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
393 name_dsc.dsc$b_class = DSC$K_CLASS_S;
395 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
397 if ($VMS_STATUS_SUCCESS(status)) {
399 /* Null terminate and return the string */
400 /*--------------------------------------*/
409 /* Is this a UNIX file specification?
410 * No longer a simple check with EFS file specs
411 * For now, not a full check, but need to
412 * handle POSIX ^UP^ specifications
413 * Fixing to handle ^/ cases would require
414 * changes to many other conversion routines.
417 static int is_unix_filespec(const char *path)
423 if (strncmp(path,"\"^UP^",5) != 0) {
424 pch1 = strchr(path, '/');
429 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
430 if (decc_filename_unix_report || decc_filename_unix_only) {
431 if (strcmp(path,".") == 0)
439 /* This routine converts a UCS-2 character to be VTF-7 encoded.
442 static void ucs2_to_vtf7
444 unsigned long ucs2_char,
447 unsigned char * ucs_ptr;
450 ucs_ptr = (unsigned char *)&ucs2_char;
454 hex = (ucs_ptr[1] >> 4) & 0xf;
456 outspec[2] = hex + '0';
458 outspec[2] = (hex - 9) + 'A';
459 hex = ucs_ptr[1] & 0xF;
461 outspec[3] = hex + '0';
463 outspec[3] = (hex - 9) + 'A';
465 hex = (ucs_ptr[0] >> 4) & 0xf;
467 outspec[4] = hex + '0';
469 outspec[4] = (hex - 9) + 'A';
470 hex = ucs_ptr[1] & 0xF;
472 outspec[5] = hex + '0';
474 outspec[5] = (hex - 9) + 'A';
480 /* This handles the conversion of a UNIX extended character set to a ^
481 * escaped VMS character.
482 * in a UNIX file specification.
484 * The output count variable contains the number of characters added
485 * to the output string.
487 * The return value is the number of characters read from the input string
489 static int copy_expand_unix_filename_escape
490 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
498 utf8_flag = *utf8_fl;
502 if (*inspec >= 0x80) {
503 if (utf8_fl && vms_vtf7_filenames) {
504 unsigned long ucs_char;
508 if ((*inspec & 0xE0) == 0xC0) {
510 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
511 if (ucs_char >= 0x80) {
512 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
515 } else if ((*inspec & 0xF0) == 0xE0) {
517 ucs_char = ((inspec[0] & 0xF) << 12) +
518 ((inspec[1] & 0x3f) << 6) +
520 if (ucs_char >= 0x800) {
521 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
525 #if 0 /* I do not see longer sequences supported by OpenVMS */
526 /* Maybe some one can fix this later */
527 } else if ((*inspec & 0xF8) == 0xF0) {
530 } else if ((*inspec & 0xFC) == 0xF8) {
533 } else if ((*inspec & 0xFE) == 0xFC) {
540 /* High bit set, but not a Unicode character! */
542 /* Non printing DECMCS or ISO Latin-1 character? */
543 if (*inspec <= 0x9F) {
547 hex = (*inspec >> 4) & 0xF;
549 outspec[1] = hex + '0';
551 outspec[1] = (hex - 9) + 'A';
555 outspec[2] = hex + '0';
557 outspec[2] = (hex - 9) + 'A';
561 } else if (*inspec == 0xA0) {
567 } else if (*inspec == 0xFF) {
579 /* Is this a macro that needs to be passed through?
580 * Macros start with $( and an alpha character, followed
581 * by a string of alpha numeric characters ending with a )
582 * If this does not match, then encode it as ODS-5.
584 if ((inspec[0] == '$') && (inspec[1] == '(')) {
587 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
589 outspec[0] = inspec[0];
590 outspec[1] = inspec[1];
591 outspec[2] = inspec[2];
593 while(isalnum(inspec[tcnt]) ||
594 (inspec[2] == '.') || (inspec[2] == '_')) {
595 outspec[tcnt] = inspec[tcnt];
598 if (inspec[tcnt] == ')') {
599 outspec[tcnt] = inspec[tcnt];
616 if (decc_efs_charset == 0)
643 /* Don't escape again if following character is
644 * already something we escape.
646 if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
652 /* But otherwise fall through and escape it. */
654 /* Assume that this is to be escaped */
656 outspec[1] = *inspec;
660 case ' ': /* space */
661 /* Assume that this is to be escaped */
676 /* This handles the expansion of a '^' prefix to the proper character
677 * in a UNIX file specification.
679 * The output count variable contains the number of characters added
680 * to the output string.
682 * The return value is the number of characters read from the input
685 static int copy_expand_vms_filename_escape
686 (char *outspec, const char *inspec, int *output_cnt)
693 if (*inspec == '^') {
696 /* Spaces and non-trailing dots should just be passed through,
697 * but eat the escape character.
704 case '_': /* space */
710 /* Hmm. Better leave the escape escaped. */
716 case 'U': /* Unicode - FIX-ME this is wrong. */
719 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
722 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
723 outspec[0] == c1 & 0xff;
724 outspec[1] == c2 & 0xff;
731 /* Error - do best we can to continue */
741 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
745 scnt = sscanf(inspec, "%2x", &c1);
746 outspec[0] = c1 & 0xff;
770 (const struct dsc$descriptor_s * srcstr,
771 struct filescan_itmlst_2 * valuelist,
772 unsigned long * fldflags,
773 struct dsc$descriptor_s *auxout,
774 unsigned short * retlen);
777 /* vms_split_path - Verify that the input file specification is a
778 * VMS format file specification, and provide pointers to the components of
779 * it. With EFS format filenames, this is virtually the only way to
780 * parse a VMS path specification into components.
782 * If the sum of the components do not add up to the length of the
783 * string, then the passed file specification is probably a UNIX style
786 static int vms_split_path
801 struct dsc$descriptor path_desc;
805 struct filescan_itmlst_2 item_list[9];
806 const int filespec = 0;
807 const int nodespec = 1;
808 const int devspec = 2;
809 const int rootspec = 3;
810 const int dirspec = 4;
811 const int namespec = 5;
812 const int typespec = 6;
813 const int verspec = 7;
815 /* Assume the worst for an easy exit */
830 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
831 path_desc.dsc$w_length = strlen(path);
832 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
833 path_desc.dsc$b_class = DSC$K_CLASS_S;
835 /* Get the total length, if it is shorter than the string passed
836 * then this was probably not a VMS formatted file specification
838 item_list[filespec].itmcode = FSCN$_FILESPEC;
839 item_list[filespec].length = 0;
840 item_list[filespec].component = NULL;
842 /* If the node is present, then it gets considered as part of the
843 * volume name to hopefully make things simple.
845 item_list[nodespec].itmcode = FSCN$_NODE;
846 item_list[nodespec].length = 0;
847 item_list[nodespec].component = NULL;
849 item_list[devspec].itmcode = FSCN$_DEVICE;
850 item_list[devspec].length = 0;
851 item_list[devspec].component = NULL;
853 /* root is a special case, adding it to either the directory or
854 * the device components will probalby complicate things for the
855 * callers of this routine, so leave it separate.
857 item_list[rootspec].itmcode = FSCN$_ROOT;
858 item_list[rootspec].length = 0;
859 item_list[rootspec].component = NULL;
861 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
862 item_list[dirspec].length = 0;
863 item_list[dirspec].component = NULL;
865 item_list[namespec].itmcode = FSCN$_NAME;
866 item_list[namespec].length = 0;
867 item_list[namespec].component = NULL;
869 item_list[typespec].itmcode = FSCN$_TYPE;
870 item_list[typespec].length = 0;
871 item_list[typespec].component = NULL;
873 item_list[verspec].itmcode = FSCN$_VERSION;
874 item_list[verspec].length = 0;
875 item_list[verspec].component = NULL;
877 item_list[8].itmcode = 0;
878 item_list[8].length = 0;
879 item_list[8].component = NULL;
881 status = sys$filescan
882 ((const struct dsc$descriptor_s *)&path_desc, item_list,
884 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
886 /* If we parsed it successfully these two lengths should be the same */
887 if (path_desc.dsc$w_length != item_list[filespec].length)
890 /* If we got here, then it is a VMS file specification */
893 /* set the volume name */
894 if (item_list[nodespec].length > 0) {
895 *volume = item_list[nodespec].component;
896 *vol_len = item_list[nodespec].length + item_list[devspec].length;
899 *volume = item_list[devspec].component;
900 *vol_len = item_list[devspec].length;
903 *root = item_list[rootspec].component;
904 *root_len = item_list[rootspec].length;
906 *dir = item_list[dirspec].component;
907 *dir_len = item_list[dirspec].length;
909 /* Now fun with versions and EFS file specifications
910 * The parser can not tell the difference when a "." is a version
911 * delimiter or a part of the file specification.
913 if ((decc_efs_charset) &&
914 (item_list[verspec].length > 0) &&
915 (item_list[verspec].component[0] == '.')) {
916 *name = item_list[namespec].component;
917 *name_len = item_list[namespec].length + item_list[typespec].length;
918 *ext = item_list[verspec].component;
919 *ext_len = item_list[verspec].length;
924 *name = item_list[namespec].component;
925 *name_len = item_list[namespec].length;
926 *ext = item_list[typespec].component;
927 *ext_len = item_list[typespec].length;
928 *version = item_list[verspec].component;
929 *ver_len = item_list[verspec].length;
934 /* Routine to determine if the file specification ends with .dir */
935 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
937 /* e_len must be 4, and version must be <= 2 characters */
938 if (e_len != 4 || vs_len > 2)
941 /* If a version number is present, it needs to be one */
942 if ((vs_len == 2) && (vs_spec[1] != '1'))
945 /* Look for the DIR on the extension */
946 if (vms_process_case_tolerant) {
947 if ((toupper(e_spec[1]) == 'D') &&
948 (toupper(e_spec[2]) == 'I') &&
949 (toupper(e_spec[3]) == 'R')) {
953 /* Directory extensions are supposed to be in upper case only */
954 /* I would not be surprised if this rule can not be enforced */
955 /* if and when someone fully debugs the case sensitive mode */
956 if ((e_spec[1] == 'D') &&
957 (e_spec[2] == 'I') &&
958 (e_spec[3] == 'R')) {
967 * Routine to retrieve the maximum equivalence index for an input
968 * logical name. Some calls to this routine have no knowledge if
969 * the variable is a logical or not. So on error we return a max
972 /*{{{int my_maxidx(const char *lnm) */
974 my_maxidx(const char *lnm)
978 int attr = LNM$M_CASE_BLIND;
979 struct dsc$descriptor lnmdsc;
980 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
983 lnmdsc.dsc$w_length = strlen(lnm);
984 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
985 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
986 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
988 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
989 if ((status & 1) == 0)
996 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
998 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
999 struct dsc$descriptor_s **tabvec, unsigned long int flags)
1002 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
1003 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
1004 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
1006 unsigned char acmode;
1007 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1008 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1009 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
1010 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
1012 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1013 #if defined(PERL_IMPLICIT_CONTEXT)
1016 aTHX = PERL_GET_INTERP;
1022 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
1023 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
1025 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1026 *cp2 = _toupper(*cp1);
1027 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1028 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1032 lnmdsc.dsc$w_length = cp1 - lnm;
1033 lnmdsc.dsc$a_pointer = uplnm;
1034 uplnm[lnmdsc.dsc$w_length] = '\0';
1035 secure = flags & PERL__TRNENV_SECURE;
1036 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
1037 if (!tabvec || !*tabvec) tabvec = env_tables;
1039 for (curtab = 0; tabvec[curtab]; curtab++) {
1040 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1041 if (!ivenv && !secure) {
1046 #if defined(PERL_IMPLICIT_CONTEXT)
1049 "%%PERL-W-VMS_INIT Can't read CRTL environ\n");
1052 Perl_warn(aTHX_ "Can't read CRTL environ\n");
1055 retsts = SS$_NOLOGNAM;
1056 for (i = 0; environ[i]; i++) {
1057 if ((eq = strchr(environ[i],'=')) &&
1058 lnmdsc.dsc$w_length == (eq - environ[i]) &&
1059 !strncmp(environ[i],uplnm,eq - environ[i])) {
1061 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
1062 if (!eqvlen) continue;
1063 retsts = SS$_NORMAL;
1067 if (retsts != SS$_NOLOGNAM) break;
1070 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1071 !str$case_blind_compare(&tmpdsc,&clisym)) {
1072 if (!ivsym && !secure) {
1073 unsigned short int deflen = LNM$C_NAMLENGTH;
1074 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1075 /* dynamic dsc to accomodate possible long value */
1076 _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
1077 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1079 if (eqvlen > MAX_DCL_SYMBOL) {
1080 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1081 eqvlen = MAX_DCL_SYMBOL;
1082 /* Special hack--we might be called before the interpreter's */
1083 /* fully initialized, in which case either thr or PL_curcop */
1084 /* might be bogus. We have to check, since ckWARN needs them */
1085 /* both to be valid if running threaded */
1086 #if defined(PERL_IMPLICIT_CONTEXT)
1089 "%Perl-VMS-Init, Value of CLI symbol \"%s\" too long",lnm);
1092 if (ckWARN(WARN_MISC)) {
1093 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1096 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1098 _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1099 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1100 if (retsts == LIB$_NOSUCHSYM) continue;
1105 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1106 midx = my_maxidx(lnm);
1107 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1108 lnmlst[1].bufadr = cp2;
1110 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1111 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1112 if (retsts == SS$_NOLOGNAM) break;
1113 /* PPFs have a prefix */
1116 *((int *)uplnm) == *((int *)"SYS$") &&
1118 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1119 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1120 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1121 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1122 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
1123 memmove(eqv,eqv+4,eqvlen-4);
1129 if ((retsts == SS$_IVLOGNAM) ||
1130 (retsts == SS$_NOLOGNAM)) { continue; }
1133 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1134 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1135 if (retsts == SS$_NOLOGNAM) continue;
1138 eqvlen = strlen(eqv);
1142 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1143 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1144 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1145 retsts == SS$_NOLOGNAM) {
1146 set_errno(EINVAL); set_vaxc_errno(retsts);
1148 else _ckvmssts_noperl(retsts);
1150 } /* end of vmstrnenv */
1153 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1154 /* Define as a function so we can access statics. */
1155 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1159 #if defined(PERL_IMPLICIT_CONTEXT)
1162 #ifdef SECURE_INTERNAL_GETENV
1163 flags = (PL_curinterp ? PL_tainting : will_taint) ?
1164 PERL__TRNENV_SECURE : 0;
1167 return vmstrnenv(lnm, eqv, idx, fildev, flags);
1172 * Note: Uses Perl temp to store result so char * can be returned to
1173 * caller; this pointer will be invalidated at next Perl statement
1175 * We define this as a function rather than a macro in terms of my_getenv_len()
1176 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1179 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1181 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1184 static char *__my_getenv_eqv = NULL;
1185 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1186 unsigned long int idx = 0;
1187 int trnsuccess, success, secure, saverr, savvmserr;
1191 midx = my_maxidx(lnm) + 1;
1193 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1194 /* Set up a temporary buffer for the return value; Perl will
1195 * clean it up at the next statement transition */
1196 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1197 if (!tmpsv) return NULL;
1201 /* Assume no interpreter ==> single thread */
1202 if (__my_getenv_eqv != NULL) {
1203 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1206 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1208 eqv = __my_getenv_eqv;
1211 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1212 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1214 getcwd(eqv,LNM$C_NAMLENGTH);
1218 /* Get rid of "000000/ in rooted filespecs */
1221 zeros = strstr(eqv, "/000000/");
1222 if (zeros != NULL) {
1224 mlen = len - (zeros - eqv) - 7;
1225 memmove(zeros, &zeros[7], mlen);
1233 /* Impose security constraints only if tainting */
1235 /* Impose security constraints only if tainting */
1236 secure = PL_curinterp ? PL_tainting : will_taint;
1237 saverr = errno; savvmserr = vaxc$errno;
1244 #ifdef SECURE_INTERNAL_GETENV
1245 secure ? PERL__TRNENV_SECURE : 0
1251 /* For the getenv interface we combine all the equivalence names
1252 * of a search list logical into one value to acquire a maximum
1253 * value length of 255*128 (assuming %ENV is using logicals).
1255 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1257 /* If the name contains a semicolon-delimited index, parse it
1258 * off and make sure we only retrieve the equivalence name for
1260 if ((cp2 = strchr(lnm,';')) != NULL) {
1262 uplnm[cp2-lnm] = '\0';
1263 idx = strtoul(cp2+1,NULL,0);
1265 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1268 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1270 /* Discard NOLOGNAM on internal calls since we're often looking
1271 * for an optional name, and this "error" often shows up as the
1272 * (bogus) exit status for a die() call later on. */
1273 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1274 return success ? eqv : NULL;
1277 } /* end of my_getenv() */
1281 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1283 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1287 unsigned long idx = 0;
1289 static char *__my_getenv_len_eqv = NULL;
1290 int secure, saverr, savvmserr;
1293 midx = my_maxidx(lnm) + 1;
1295 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1296 /* Set up a temporary buffer for the return value; Perl will
1297 * clean it up at the next statement transition */
1298 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1299 if (!tmpsv) return NULL;
1303 /* Assume no interpreter ==> single thread */
1304 if (__my_getenv_len_eqv != NULL) {
1305 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1308 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1310 buf = __my_getenv_len_eqv;
1313 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1314 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1317 getcwd(buf,LNM$C_NAMLENGTH);
1320 /* Get rid of "000000/ in rooted filespecs */
1322 zeros = strstr(buf, "/000000/");
1323 if (zeros != NULL) {
1325 mlen = *len - (zeros - buf) - 7;
1326 memmove(zeros, &zeros[7], mlen);
1335 /* Impose security constraints only if tainting */
1336 secure = PL_curinterp ? PL_tainting : will_taint;
1337 saverr = errno; savvmserr = vaxc$errno;
1344 #ifdef SECURE_INTERNAL_GETENV
1345 secure ? PERL__TRNENV_SECURE : 0
1351 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1353 if ((cp2 = strchr(lnm,';')) != NULL) {
1355 buf[cp2-lnm] = '\0';
1356 idx = strtoul(cp2+1,NULL,0);
1358 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1361 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1363 /* Get rid of "000000/ in rooted filespecs */
1366 zeros = strstr(buf, "/000000/");
1367 if (zeros != NULL) {
1369 mlen = *len - (zeros - buf) - 7;
1370 memmove(zeros, &zeros[7], mlen);
1376 /* Discard NOLOGNAM on internal calls since we're often looking
1377 * for an optional name, and this "error" often shows up as the
1378 * (bogus) exit status for a die() call later on. */
1379 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1380 return *len ? buf : NULL;
1383 } /* end of my_getenv_len() */
1386 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1388 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1390 /*{{{ void prime_env_iter() */
1392 prime_env_iter(void)
1393 /* Fill the %ENV associative array with all logical names we can
1394 * find, in preparation for iterating over it.
1397 static int primed = 0;
1398 HV *seenhv = NULL, *envhv;
1400 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1401 unsigned short int chan;
1402 #ifndef CLI$M_TRUSTED
1403 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1405 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1406 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1408 bool have_sym = FALSE, have_lnm = FALSE;
1409 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1410 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1411 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1412 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1413 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1414 #if defined(PERL_IMPLICIT_CONTEXT)
1417 #if defined(USE_ITHREADS)
1418 static perl_mutex primenv_mutex;
1419 MUTEX_INIT(&primenv_mutex);
1422 #if defined(PERL_IMPLICIT_CONTEXT)
1423 /* We jump through these hoops because we can be called at */
1424 /* platform-specific initialization time, which is before anything is */
1425 /* set up--we can't even do a plain dTHX since that relies on the */
1426 /* interpreter structure to be initialized */
1428 aTHX = PERL_GET_INTERP;
1430 /* we never get here because the NULL pointer will cause the */
1431 /* several of the routines called by this routine to access violate */
1433 /* This routine is only called by hv.c/hv_iterinit which has a */
1434 /* context, so the real fix may be to pass it through instead of */
1435 /* the hoops above */
1440 if (primed || !PL_envgv) return;
1441 MUTEX_LOCK(&primenv_mutex);
1442 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1443 envhv = GvHVn(PL_envgv);
1444 /* Perform a dummy fetch as an lval to insure that the hash table is
1445 * set up. Otherwise, the hv_store() will turn into a nullop. */
1446 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1448 for (i = 0; env_tables[i]; i++) {
1449 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1450 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1451 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1453 if (have_sym || have_lnm) {
1454 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1455 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1456 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1457 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1460 for (i--; i >= 0; i--) {
1461 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1464 for (j = 0; environ[j]; j++) {
1465 if (!(start = strchr(environ[j],'='))) {
1466 if (ckWARN(WARN_INTERNAL))
1467 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1471 sv = newSVpv(start,0);
1473 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1478 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1479 !str$case_blind_compare(&tmpdsc,&clisym)) {
1480 strcpy(cmd,"Show Symbol/Global *");
1481 cmddsc.dsc$w_length = 20;
1482 if (env_tables[i]->dsc$w_length == 12 &&
1483 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1484 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1485 flags = defflags | CLI$M_NOLOGNAM;
1488 strcpy(cmd,"Show Logical *");
1489 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1490 strcat(cmd," /Table=");
1491 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1492 cmddsc.dsc$w_length = strlen(cmd);
1494 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1495 flags = defflags | CLI$M_NOCLISYM;
1498 /* Create a new subprocess to execute each command, to exclude the
1499 * remote possibility that someone could subvert a mbx or file used
1500 * to write multiple commands to a single subprocess.
1503 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1504 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1505 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1506 defflags &= ~CLI$M_TRUSTED;
1507 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1509 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1510 if (seenhv) SvREFCNT_dec(seenhv);
1513 char *cp1, *cp2, *key;
1514 unsigned long int sts, iosb[2], retlen, keylen;
1517 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1518 if (sts & 1) sts = iosb[0] & 0xffff;
1519 if (sts == SS$_ENDOFFILE) {
1521 while (substs == 0) { sys$hiber(); wakect++;}
1522 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1527 retlen = iosb[0] >> 16;
1528 if (!retlen) continue; /* blank line */
1530 if (iosb[1] != subpid) {
1532 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1536 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1537 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1539 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1540 if (*cp1 == '(' || /* Logical name table name */
1541 *cp1 == '=' /* Next eqv of searchlist */) continue;
1542 if (*cp1 == '"') cp1++;
1543 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1544 key = cp1; keylen = cp2 - cp1;
1545 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1546 while (*cp2 && *cp2 != '=') cp2++;
1547 while (*cp2 && *cp2 == '=') cp2++;
1548 while (*cp2 && *cp2 == ' ') cp2++;
1549 if (*cp2 == '"') { /* String translation; may embed "" */
1550 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1551 cp2++; cp1--; /* Skip "" surrounding translation */
1553 else { /* Numeric translation */
1554 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1555 cp1--; /* stop on last non-space char */
1557 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1558 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1561 PERL_HASH(hash,key,keylen);
1563 if (cp1 == cp2 && *cp2 == '.') {
1564 /* A single dot usually means an unprintable character, such as a null
1565 * to indicate a zero-length value. Get the actual value to make sure.
1567 char lnm[LNM$C_NAMLENGTH+1];
1568 char eqv[MAX_DCL_SYMBOL+1];
1570 strncpy(lnm, key, keylen);
1571 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1572 sv = newSVpvn(eqv, strlen(eqv));
1575 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1579 hv_store(envhv,key,keylen,sv,hash);
1580 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1582 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1583 /* get the PPFs for this process, not the subprocess */
1584 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1585 char eqv[LNM$C_NAMLENGTH+1];
1587 for (i = 0; ppfs[i]; i++) {
1588 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1589 sv = newSVpv(eqv,trnlen);
1591 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1596 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1597 if (buf) Safefree(buf);
1598 if (seenhv) SvREFCNT_dec(seenhv);
1599 MUTEX_UNLOCK(&primenv_mutex);
1602 } /* end of prime_env_iter */
1606 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1607 /* Define or delete an element in the same "environment" as
1608 * vmstrnenv(). If an element is to be deleted, it's removed from
1609 * the first place it's found. If it's to be set, it's set in the
1610 * place designated by the first element of the table vector.
1611 * Like setenv() returns 0 for success, non-zero on error.
1614 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1617 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1618 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1620 unsigned long int retsts, usermode = PSL$C_USER;
1621 struct itmlst_3 *ile, *ilist;
1622 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1623 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1624 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1625 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1626 $DESCRIPTOR(local,"_LOCAL");
1629 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1630 return SS$_IVLOGNAM;
1633 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1634 *cp2 = _toupper(*cp1);
1635 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1636 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1637 return SS$_IVLOGNAM;
1640 lnmdsc.dsc$w_length = cp1 - lnm;
1641 if (!tabvec || !*tabvec) tabvec = env_tables;
1643 if (!eqv) { /* we're deleting n element */
1644 for (curtab = 0; tabvec[curtab]; curtab++) {
1645 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1647 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1648 if ((cp1 = strchr(environ[i],'=')) &&
1649 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1650 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1652 return setenv(lnm,"",1) ? vaxc$errno : 0;
1655 ivenv = 1; retsts = SS$_NOLOGNAM;
1657 if (ckWARN(WARN_INTERNAL))
1658 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1659 ivenv = 1; retsts = SS$_NOSUCHPGM;
1665 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1666 !str$case_blind_compare(&tmpdsc,&clisym)) {
1667 unsigned int symtype;
1668 if (tabvec[curtab]->dsc$w_length == 12 &&
1669 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1670 !str$case_blind_compare(&tmpdsc,&local))
1671 symtype = LIB$K_CLI_LOCAL_SYM;
1672 else symtype = LIB$K_CLI_GLOBAL_SYM;
1673 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1674 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1675 if (retsts == LIB$_NOSUCHSYM) continue;
1679 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1680 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1681 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1682 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1683 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1687 else { /* we're defining a value */
1688 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1690 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1692 if (ckWARN(WARN_INTERNAL))
1693 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1694 retsts = SS$_NOSUCHPGM;
1698 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1699 eqvdsc.dsc$w_length = strlen(eqv);
1700 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1701 !str$case_blind_compare(&tmpdsc,&clisym)) {
1702 unsigned int symtype;
1703 if (tabvec[0]->dsc$w_length == 12 &&
1704 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1705 !str$case_blind_compare(&tmpdsc,&local))
1706 symtype = LIB$K_CLI_LOCAL_SYM;
1707 else symtype = LIB$K_CLI_GLOBAL_SYM;
1708 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1711 if (!*eqv) eqvdsc.dsc$w_length = 1;
1712 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1714 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1715 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1716 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1717 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1718 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1719 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1722 Newx(ilist,nseg+1,struct itmlst_3);
1725 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1728 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1730 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1731 ile->itmcode = LNM$_STRING;
1733 if ((j+1) == nseg) {
1734 ile->buflen = strlen(c);
1735 /* in case we are truncating one that's too long */
1736 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1739 ile->buflen = LNM$C_NAMLENGTH;
1743 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1747 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1752 if (!(retsts & 1)) {
1754 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1755 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1756 set_errno(EVMSERR); break;
1757 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1758 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1759 set_errno(EINVAL); break;
1761 set_errno(EACCES); break;
1766 set_vaxc_errno(retsts);
1767 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1770 /* We reset error values on success because Perl does an hv_fetch()
1771 * before each hv_store(), and if the thing we're setting didn't
1772 * previously exist, we've got a leftover error message. (Of course,
1773 * this fails in the face of
1774 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1775 * in that the error reported in $! isn't spurious,
1776 * but it's right more often than not.)
1778 set_errno(0); set_vaxc_errno(retsts);
1782 } /* end of vmssetenv() */
1785 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1786 /* This has to be a function since there's a prototype for it in proto.h */
1788 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1791 int len = strlen(lnm);
1795 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1796 if (!strcmp(uplnm,"DEFAULT")) {
1797 if (eqv && *eqv) my_chdir(eqv);
1801 #ifndef RTL_USES_UTC
1802 if (len == 6 || len == 2) {
1805 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1807 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1808 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1812 (void) vmssetenv(lnm,eqv,NULL);
1816 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1818 * sets a user-mode logical in the process logical name table
1819 * used for redirection of sys$error
1822 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1824 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1825 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1826 unsigned long int iss, attr = LNM$M_CONFINE;
1827 unsigned char acmode = PSL$C_USER;
1828 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1830 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1831 d_name.dsc$w_length = strlen(name);
1833 lnmlst[0].buflen = strlen(eqv);
1834 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1836 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1837 if (!(iss&1)) lib$signal(iss);
1842 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1843 /* my_crypt - VMS password hashing
1844 * my_crypt() provides an interface compatible with the Unix crypt()
1845 * C library function, and uses sys$hash_password() to perform VMS
1846 * password hashing. The quadword hashed password value is returned
1847 * as a NUL-terminated 8 character string. my_crypt() does not change
1848 * the case of its string arguments; in order to match the behavior
1849 * of LOGINOUT et al., alphabetic characters in both arguments must
1850 * be upcased by the caller.
1852 * - fix me to call ACM services when available
1855 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1857 # ifndef UAI$C_PREFERRED_ALGORITHM
1858 # define UAI$C_PREFERRED_ALGORITHM 127
1860 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1861 unsigned short int salt = 0;
1862 unsigned long int sts;
1864 unsigned short int dsc$w_length;
1865 unsigned char dsc$b_type;
1866 unsigned char dsc$b_class;
1867 const char * dsc$a_pointer;
1868 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1869 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1870 struct itmlst_3 uailst[3] = {
1871 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1872 { sizeof salt, UAI$_SALT, &salt, 0},
1873 { 0, 0, NULL, NULL}};
1874 static char hash[9];
1876 usrdsc.dsc$w_length = strlen(usrname);
1877 usrdsc.dsc$a_pointer = usrname;
1878 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1880 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1884 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1889 set_vaxc_errno(sts);
1890 if (sts != RMS$_RNF) return NULL;
1893 txtdsc.dsc$w_length = strlen(textpasswd);
1894 txtdsc.dsc$a_pointer = textpasswd;
1895 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1896 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1899 return (char *) hash;
1901 } /* end of my_crypt() */
1905 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1906 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1907 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1909 /* fixup barenames that are directories for internal use.
1910 * There have been problems with the consistent handling of UNIX
1911 * style directory names when routines are presented with a name that
1912 * has no directory delimitors at all. So this routine will eventually
1915 static char * fixup_bare_dirnames(const char * name)
1917 if (decc_disable_to_vms_logname_translation) {
1923 /* 8.3, remove() is now broken on symbolic links */
1924 static int rms_erase(const char * vmsname);
1928 * A little hack to get around a bug in some implemenation of remove()
1929 * that do not know how to delete a directory
1931 * Delete any file to which user has control access, regardless of whether
1932 * delete access is explicitly allowed.
1933 * Limitations: User must have write access to parent directory.
1934 * Does not block signals or ASTs; if interrupted in midstream
1935 * may leave file with an altered ACL.
1938 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1940 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1944 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1945 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1946 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1948 unsigned char myace$b_length;
1949 unsigned char myace$b_type;
1950 unsigned short int myace$w_flags;
1951 unsigned long int myace$l_access;
1952 unsigned long int myace$l_ident;
1953 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1954 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1955 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1957 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1958 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1959 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1960 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1961 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1962 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1964 /* Expand the input spec using RMS, since the CRTL remove() and
1965 * system services won't do this by themselves, so we may miss
1966 * a file "hiding" behind a logical name or search list. */
1967 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1968 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1970 rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1972 PerlMem_free(vmsname);
1976 /* Erase the file */
1977 rmsts = rms_erase(vmsname);
1979 /* Did it succeed */
1980 if ($VMS_STATUS_SUCCESS(rmsts)) {
1981 PerlMem_free(vmsname);
1985 /* If not, can changing protections help? */
1986 if (rmsts != RMS$_PRV) {
1987 set_vaxc_errno(rmsts);
1988 PerlMem_free(vmsname);
1992 /* No, so we get our own UIC to use as a rights identifier,
1993 * and the insert an ACE at the head of the ACL which allows us
1994 * to delete the file.
1996 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1997 fildsc.dsc$w_length = strlen(vmsname);
1998 fildsc.dsc$a_pointer = vmsname;
2000 newace.myace$l_ident = oldace.myace$l_ident;
2002 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2004 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2005 set_errno(ENOENT); break;
2007 set_errno(ENOTDIR); break;
2009 set_errno(ENODEV); break;
2010 case RMS$_SYN: case SS$_INVFILFOROP:
2011 set_errno(EINVAL); break;
2013 set_errno(EACCES); break;
2015 _ckvmssts_noperl(aclsts);
2017 set_vaxc_errno(aclsts);
2018 PerlMem_free(vmsname);
2021 /* Grab any existing ACEs with this identifier in case we fail */
2022 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2023 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2024 || fndsts == SS$_NOMOREACE ) {
2025 /* Add the new ACE . . . */
2026 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2029 rmsts = rms_erase(vmsname);
2030 if ($VMS_STATUS_SUCCESS(rmsts)) {
2035 /* We blew it - dir with files in it, no write priv for
2036 * parent directory, etc. Put things back the way they were. */
2037 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2040 addlst[0].bufadr = &oldace;
2041 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2048 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2049 /* We just deleted it, so of course it's not there. Some versions of
2050 * VMS seem to return success on the unlock operation anyhow (after all
2051 * the unlock is successful), but others don't.
2053 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2054 if (aclsts & 1) aclsts = fndsts;
2055 if (!(aclsts & 1)) {
2057 set_vaxc_errno(aclsts);
2060 PerlMem_free(vmsname);
2063 } /* end of kill_file() */
2067 /*{{{int do_rmdir(char *name)*/
2069 Perl_do_rmdir(pTHX_ const char *name)
2075 dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
2076 if (dirfile == NULL)
2077 _ckvmssts(SS$_INSFMEM);
2079 /* Force to a directory specification */
2080 if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
2081 PerlMem_free(dirfile);
2084 if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
2089 retval = mp_do_kill_file(aTHX_ dirfile, 1);
2091 PerlMem_free(dirfile);
2094 } /* end of do_rmdir */
2098 * Delete any file to which user has control access, regardless of whether
2099 * delete access is explicitly allowed.
2100 * Limitations: User must have write access to parent directory.
2101 * Does not block signals or ASTs; if interrupted in midstream
2102 * may leave file with an altered ACL.
2105 /*{{{int kill_file(char *name)*/
2107 Perl_kill_file(pTHX_ const char *name)
2109 char rspec[NAM$C_MAXRSS+1];
2114 /* Remove() is allowed to delete directories, according to the X/Open
2116 * This may need special handling to work with the ACL hacks.
2118 if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2119 rmsts = Perl_do_rmdir(aTHX_ name);
2123 rmsts = mp_do_kill_file(aTHX_ name, 0);
2127 } /* end of kill_file() */
2131 /*{{{int my_mkdir(char *,Mode_t)*/
2133 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2135 STRLEN dirlen = strlen(dir);
2137 /* zero length string sometimes gives ACCVIO */
2138 if (dirlen == 0) return -1;
2140 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2141 * null file name/type. However, it's commonplace under Unix,
2142 * so we'll allow it for a gain in portability.
2144 if (dir[dirlen-1] == '/') {
2145 char *newdir = savepvn(dir,dirlen-1);
2146 int ret = mkdir(newdir,mode);
2150 else return mkdir(dir,mode);
2151 } /* end of my_mkdir */
2154 /*{{{int my_chdir(char *)*/
2156 Perl_my_chdir(pTHX_ const char *dir)
2158 STRLEN dirlen = strlen(dir);
2160 /* zero length string sometimes gives ACCVIO */
2161 if (dirlen == 0) return -1;
2164 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2165 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2166 * so that existing scripts do not need to be changed.
2169 while ((dirlen > 0) && (*dir1 == ' ')) {
2174 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2176 * null file name/type. However, it's commonplace under Unix,
2177 * so we'll allow it for a gain in portability.
2179 * - Preview- '/' will be valid soon on VMS
2181 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2182 char *newdir = savepvn(dir1,dirlen-1);
2183 int ret = chdir(newdir);
2187 else return chdir(dir1);
2188 } /* end of my_chdir */
2192 /*{{{int my_chmod(char *, mode_t)*/
2194 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2196 STRLEN speclen = strlen(file_spec);
2198 /* zero length string sometimes gives ACCVIO */
2199 if (speclen == 0) return -1;
2201 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2202 * that implies null file name/type. However, it's commonplace under Unix,
2203 * so we'll allow it for a gain in portability.
2205 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2206 * in VMS file.dir notation.
2208 if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2209 char *vms_src, *vms_dir, *rslt;
2213 /* First convert this to a VMS format specification */
2214 vms_src = PerlMem_malloc(VMS_MAXRSS);
2215 if (vms_src == NULL)
2216 _ckvmssts_noperl(SS$_INSFMEM);
2218 rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2220 /* If we fail, then not a file specification */
2221 PerlMem_free(vms_src);
2226 /* Now make it a directory spec so chmod is happy */
2227 vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2228 if (vms_dir == NULL)
2229 _ckvmssts_noperl(SS$_INSFMEM);
2230 rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2231 PerlMem_free(vms_src);
2235 ret = chmod(vms_dir, mode);
2239 PerlMem_free(vms_dir);
2242 else return chmod(file_spec, mode);
2243 } /* end of my_chmod */
2247 /*{{{FILE *my_tmpfile()*/
2254 if ((fp = tmpfile())) return fp;
2256 cp = PerlMem_malloc(L_tmpnam+24);
2257 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2259 if (decc_filename_unix_only == 0)
2260 strcpy(cp,"Sys$Scratch:");
2263 tmpnam(cp+strlen(cp));
2264 strcat(cp,".Perltmp");
2265 fp = fopen(cp,"w+","fop=dlt");
2272 #ifndef HOMEGROWN_POSIX_SIGNALS
2274 * The C RTL's sigaction fails to check for invalid signal numbers so we
2275 * help it out a bit. The docs are correct, but the actual routine doesn't
2276 * do what the docs say it will.
2278 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2280 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2281 struct sigaction* oact)
2283 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2284 SETERRNO(EINVAL, SS$_INVARG);
2287 return sigaction(sig, act, oact);
2292 #ifdef KILL_BY_SIGPRC
2293 #include <errnodef.h>
2295 /* We implement our own kill() using the undocumented system service
2296 sys$sigprc for one of two reasons:
2298 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2299 target process to do a sys$exit, which usually can't be handled
2300 gracefully...certainly not by Perl and the %SIG{} mechanism.
2302 2.) If the kill() in the CRTL can't be called from a signal
2303 handler without disappearing into the ether, i.e., the signal
2304 it purportedly sends is never trapped. Still true as of VMS 7.3.
2306 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2307 in the target process rather than calling sys$exit.
2309 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2310 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2311 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2312 with condition codes C$_SIG0+nsig*8, catching the exception on the
2313 target process and resignaling with appropriate arguments.
2315 But we don't have that VMS 7.0+ exception handler, so if you
2316 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2318 Also note that SIGTERM is listed in the docs as being "unimplemented",
2319 yet always seems to be signaled with a VMS condition code of 4 (and
2320 correctly handled for that code). So we hardwire it in.
2322 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2323 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2324 than signalling with an unrecognized (and unhandled by CRTL) code.
2327 #define _MY_SIG_MAX 28
2330 Perl_sig_to_vmscondition_int(int sig)
2332 static unsigned int sig_code[_MY_SIG_MAX+1] =
2335 SS$_HANGUP, /* 1 SIGHUP */
2336 SS$_CONTROLC, /* 2 SIGINT */
2337 SS$_CONTROLY, /* 3 SIGQUIT */
2338 SS$_RADRMOD, /* 4 SIGILL */
2339 SS$_BREAK, /* 5 SIGTRAP */
2340 SS$_OPCCUS, /* 6 SIGABRT */
2341 SS$_COMPAT, /* 7 SIGEMT */
2343 SS$_FLTOVF, /* 8 SIGFPE VAX */
2345 SS$_HPARITH, /* 8 SIGFPE AXP */
2347 SS$_ABORT, /* 9 SIGKILL */
2348 SS$_ACCVIO, /* 10 SIGBUS */
2349 SS$_ACCVIO, /* 11 SIGSEGV */
2350 SS$_BADPARAM, /* 12 SIGSYS */
2351 SS$_NOMBX, /* 13 SIGPIPE */
2352 SS$_ASTFLT, /* 14 SIGALRM */
2369 #if __VMS_VER >= 60200000
2370 static int initted = 0;
2373 sig_code[16] = C$_SIGUSR1;
2374 sig_code[17] = C$_SIGUSR2;
2375 #if __CRTL_VER >= 70000000
2376 sig_code[20] = C$_SIGCHLD;
2378 #if __CRTL_VER >= 70300000
2379 sig_code[28] = C$_SIGWINCH;
2384 if (sig < _SIG_MIN) return 0;
2385 if (sig > _MY_SIG_MAX) return 0;
2386 return sig_code[sig];
2390 Perl_sig_to_vmscondition(int sig)
2393 if (vms_debug_on_exception != 0)
2394 lib$signal(SS$_DEBUG);
2396 return Perl_sig_to_vmscondition_int(sig);
2401 Perl_my_kill(int pid, int sig)
2406 int sys$sigprc(unsigned int *pidadr,
2407 struct dsc$descriptor_s *prcname,
2410 /* sig 0 means validate the PID */
2411 /*------------------------------*/
2413 const unsigned long int jpicode = JPI$_PID;
2416 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2417 if ($VMS_STATUS_SUCCESS(status))
2420 case SS$_NOSUCHNODE:
2421 case SS$_UNREACHABLE:
2435 code = Perl_sig_to_vmscondition_int(sig);
2438 SETERRNO(EINVAL, SS$_BADPARAM);
2442 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2443 * signals are to be sent to multiple processes.
2444 * pid = 0 - all processes in group except ones that the system exempts
2445 * pid = -1 - all processes except ones that the system exempts
2446 * pid = -n - all processes in group (abs(n)) except ...
2447 * For now, just report as not supported.
2451 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2455 iss = sys$sigprc((unsigned int *)&pid,0,code);
2456 if (iss&1) return 0;
2460 set_errno(EPERM); break;
2462 case SS$_NOSUCHNODE:
2463 case SS$_UNREACHABLE:
2464 set_errno(ESRCH); break;
2466 set_errno(ENOMEM); break;
2468 _ckvmssts_noperl(iss);
2471 set_vaxc_errno(iss);
2477 /* Routine to convert a VMS status code to a UNIX status code.
2478 ** More tricky than it appears because of conflicting conventions with
2481 ** VMS status codes are a bit mask, with the least significant bit set for
2484 ** Special UNIX status of EVMSERR indicates that no translation is currently
2485 ** available, and programs should check the VMS status code.
2487 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2491 #ifndef C_FACILITY_NO
2492 #define C_FACILITY_NO 0x350000
2495 #define DCL_IVVERB 0x38090
2498 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2506 /* Assume the best or the worst */
2507 if (vms_status & STS$M_SUCCESS)
2510 unix_status = EVMSERR;
2512 msg_status = vms_status & ~STS$M_CONTROL;
2514 facility = vms_status & STS$M_FAC_NO;
2515 fac_sp = vms_status & STS$M_FAC_SP;
2516 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2518 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2524 unix_status = EFAULT;
2526 case SS$_DEVOFFLINE:
2527 unix_status = EBUSY;
2530 unix_status = ENOTCONN;
2538 case SS$_INVFILFOROP:
2542 unix_status = EINVAL;
2544 case SS$_UNSUPPORTED:
2545 unix_status = ENOTSUP;
2550 unix_status = EACCES;
2552 case SS$_DEVICEFULL:
2553 unix_status = ENOSPC;
2556 unix_status = ENODEV;
2558 case SS$_NOSUCHFILE:
2559 case SS$_NOSUCHOBJECT:
2560 unix_status = ENOENT;
2562 case SS$_ABORT: /* Fatal case */
2563 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2564 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2565 unix_status = EINTR;
2568 unix_status = E2BIG;
2571 unix_status = ENOMEM;
2574 unix_status = EPERM;
2576 case SS$_NOSUCHNODE:
2577 case SS$_UNREACHABLE:
2578 unix_status = ESRCH;
2581 unix_status = ECHILD;
2584 if ((facility == 0) && (msg_no < 8)) {
2585 /* These are not real VMS status codes so assume that they are
2586 ** already UNIX status codes
2588 unix_status = msg_no;
2594 /* Translate a POSIX exit code to a UNIX exit code */
2595 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2596 unix_status = (msg_no & 0x07F8) >> 3;
2600 /* Documented traditional behavior for handling VMS child exits */
2601 /*--------------------------------------------------------------*/
2602 if (child_flag != 0) {
2604 /* Success / Informational return 0 */
2605 /*----------------------------------*/
2606 if (msg_no & STS$K_SUCCESS)
2609 /* Warning returns 1 */
2610 /*-------------------*/
2611 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2614 /* Everything else pass through the severity bits */
2615 /*------------------------------------------------*/
2616 return (msg_no & STS$M_SEVERITY);
2619 /* Normal VMS status to ERRNO mapping attempt */
2620 /*--------------------------------------------*/
2621 switch(msg_status) {
2622 /* case RMS$_EOF: */ /* End of File */
2623 case RMS$_FNF: /* File Not Found */
2624 case RMS$_DNF: /* Dir Not Found */
2625 unix_status = ENOENT;
2627 case RMS$_RNF: /* Record Not Found */
2628 unix_status = ESRCH;
2631 unix_status = ENOTDIR;
2634 unix_status = ENODEV;
2639 unix_status = EBADF;
2642 unix_status = EEXIST;
2646 case LIB$_INVSTRDES:
2648 case LIB$_NOSUCHSYM:
2649 case LIB$_INVSYMNAM:
2651 unix_status = EINVAL;
2657 unix_status = E2BIG;
2659 case RMS$_PRV: /* No privilege */
2660 case RMS$_ACC: /* ACP file access failed */
2661 case RMS$_WLK: /* Device write locked */
2662 unix_status = EACCES;
2664 case RMS$_MKD: /* Failed to mark for delete */
2665 unix_status = EPERM;
2667 /* case RMS$_NMF: */ /* No more files */
2675 /* Try to guess at what VMS error status should go with a UNIX errno
2676 * value. This is hard to do as there could be many possible VMS
2677 * error statuses that caused the errno value to be set.
2680 int Perl_unix_status_to_vms(int unix_status)
2682 int test_unix_status;
2684 /* Trivial cases first */
2685 /*---------------------*/
2686 if (unix_status == EVMSERR)
2689 /* Is vaxc$errno sane? */
2690 /*---------------------*/
2691 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2692 if (test_unix_status == unix_status)
2695 /* If way out of range, must be VMS code already */
2696 /*-----------------------------------------------*/
2697 if (unix_status > EVMSERR)
2700 /* If out of range, punt */
2701 /*-----------------------*/
2702 if (unix_status > __ERRNO_MAX)
2706 /* Ok, now we have to do it the hard way. */
2707 /*----------------------------------------*/
2708 switch(unix_status) {
2709 case 0: return SS$_NORMAL;
2710 case EPERM: return SS$_NOPRIV;
2711 case ENOENT: return SS$_NOSUCHOBJECT;
2712 case ESRCH: return SS$_UNREACHABLE;
2713 case EINTR: return SS$_ABORT;
2716 case E2BIG: return SS$_BUFFEROVF;
2718 case EBADF: return RMS$_IFI;
2719 case ECHILD: return SS$_NONEXPR;
2721 case ENOMEM: return SS$_INSFMEM;
2722 case EACCES: return SS$_FILACCERR;
2723 case EFAULT: return SS$_ACCVIO;
2725 case EBUSY: return SS$_DEVOFFLINE;
2726 case EEXIST: return RMS$_FEX;
2728 case ENODEV: return SS$_NOSUCHDEV;
2729 case ENOTDIR: return RMS$_DIR;
2731 case EINVAL: return SS$_INVARG;
2737 case ENOSPC: return SS$_DEVICEFULL;
2738 case ESPIPE: return LIB$_INVARG;
2743 case ERANGE: return LIB$_INVARG;
2744 /* case EWOULDBLOCK */
2745 /* case EINPROGRESS */
2748 /* case EDESTADDRREQ */
2750 /* case EPROTOTYPE */
2751 /* case ENOPROTOOPT */
2752 /* case EPROTONOSUPPORT */
2753 /* case ESOCKTNOSUPPORT */
2754 /* case EOPNOTSUPP */
2755 /* case EPFNOSUPPORT */
2756 /* case EAFNOSUPPORT */
2757 /* case EADDRINUSE */
2758 /* case EADDRNOTAVAIL */
2760 /* case ENETUNREACH */
2761 /* case ENETRESET */
2762 /* case ECONNABORTED */
2763 /* case ECONNRESET */
2766 case ENOTCONN: return SS$_CLEARED;
2767 /* case ESHUTDOWN */
2768 /* case ETOOMANYREFS */
2769 /* case ETIMEDOUT */
2770 /* case ECONNREFUSED */
2772 /* case ENAMETOOLONG */
2773 /* case EHOSTDOWN */
2774 /* case EHOSTUNREACH */
2775 /* case ENOTEMPTY */
2787 /* case ECANCELED */
2791 return SS$_UNSUPPORTED;
2797 /* case EABANDONED */
2799 return SS$_ABORT; /* punt */
2802 return SS$_ABORT; /* Should not get here */
2806 /* default piping mailbox size */
2807 #define PERL_BUFSIZ 512
2811 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2813 unsigned long int mbxbufsiz;
2814 static unsigned long int syssize = 0;
2815 unsigned long int dviitm = DVI$_DEVNAM;
2816 char csize[LNM$C_NAMLENGTH+1];
2820 unsigned long syiitm = SYI$_MAXBUF;
2822 * Get the SYSGEN parameter MAXBUF
2824 * If the logical 'PERL_MBX_SIZE' is defined
2825 * use the value of the logical instead of PERL_BUFSIZ, but
2826 * keep the size between 128 and MAXBUF.
2829 _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2832 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2833 mbxbufsiz = atoi(csize);
2835 mbxbufsiz = PERL_BUFSIZ;
2837 if (mbxbufsiz < 128) mbxbufsiz = 128;
2838 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2840 _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2842 sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2843 _ckvmssts_noperl(sts);
2844 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2846 } /* end of create_mbx() */
2849 /*{{{ my_popen and my_pclose*/
2851 typedef struct _iosb IOSB;
2852 typedef struct _iosb* pIOSB;
2853 typedef struct _pipe Pipe;
2854 typedef struct _pipe* pPipe;
2855 typedef struct pipe_details Info;
2856 typedef struct pipe_details* pInfo;
2857 typedef struct _srqp RQE;
2858 typedef struct _srqp* pRQE;
2859 typedef struct _tochildbuf CBuf;
2860 typedef struct _tochildbuf* pCBuf;
2863 unsigned short status;
2864 unsigned short count;
2865 unsigned long dvispec;
2868 #pragma member_alignment save
2869 #pragma nomember_alignment quadword
2870 struct _srqp { /* VMS self-relative queue entry */
2871 unsigned long qptr[2];
2873 #pragma member_alignment restore
2874 static RQE RQE_ZERO = {0,0};
2876 struct _tochildbuf {
2879 unsigned short size;
2887 unsigned short chan_in;
2888 unsigned short chan_out;
2890 unsigned int bufsize;
2902 #if defined(PERL_IMPLICIT_CONTEXT)
2903 void *thx; /* Either a thread or an interpreter */
2904 /* pointer, depending on how we're built */
2912 PerlIO *fp; /* file pointer to pipe mailbox */
2913 int useFILE; /* using stdio, not perlio */
2914 int pid; /* PID of subprocess */
2915 int mode; /* == 'r' if pipe open for reading */
2916 int done; /* subprocess has completed */
2917 int waiting; /* waiting for completion/closure */
2918 int closing; /* my_pclose is closing this pipe */
2919 unsigned long completion; /* termination status of subprocess */
2920 pPipe in; /* pipe in to sub */
2921 pPipe out; /* pipe out of sub */
2922 pPipe err; /* pipe of sub's sys$error */
2923 int in_done; /* true when in pipe finished */
2926 unsigned short xchan; /* channel to debug xterm */
2927 unsigned short xchan_valid; /* channel is assigned */
2930 struct exit_control_block
2932 struct exit_control_block *flink;
2933 unsigned long int (*exit_routine)();
2934 unsigned long int arg_count;
2935 unsigned long int *status_address;
2936 unsigned long int exit_status;
2939 typedef struct _closed_pipes Xpipe;
2940 typedef struct _closed_pipes* pXpipe;
2942 struct _closed_pipes {
2943 int pid; /* PID of subprocess */
2944 unsigned long completion; /* termination status of subprocess */
2946 #define NKEEPCLOSED 50
2947 static Xpipe closed_list[NKEEPCLOSED];
2948 static int closed_index = 0;
2949 static int closed_num = 0;
2951 #define RETRY_DELAY "0 ::0.20"
2952 #define MAX_RETRY 50
2954 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2955 static unsigned long mypid;
2956 static unsigned long delaytime[2];
2958 static pInfo open_pipes = NULL;
2959 static $DESCRIPTOR(nl_desc, "NL:");
2961 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2965 static unsigned long int
2969 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2970 int sts, did_stuff, need_eof, j;
2973 * Flush any pending i/o, but since we are in process run-down, be
2974 * careful about referencing PerlIO structures that may already have
2975 * been deallocated. We may not even have an interpreter anymore.
2980 #if defined(PERL_IMPLICIT_CONTEXT)
2981 /* We need to use the Perl context of the thread that created */
2985 aTHX = info->err->thx;
2987 aTHX = info->out->thx;
2989 aTHX = info->in->thx;
2992 #if defined(USE_ITHREADS)
2995 && PL_perlio_fd_refcnt)
2996 PerlIO_flush(info->fp);
2998 fflush((FILE *)info->fp);
3004 next we try sending an EOF...ignore if doesn't work, make sure we
3012 _ckvmssts_noperl(sys$setast(0));
3013 if (info->in && !info->in->shut_on_empty) {
3014 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3019 _ckvmssts_noperl(sys$setast(1));
3023 /* wait for EOF to have effect, up to ~ 30 sec [default] */
3025 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3030 _ckvmssts_noperl(sys$setast(0));
3031 if (info->waiting && info->done)
3033 nwait += info->waiting;
3034 _ckvmssts_noperl(sys$setast(1));
3044 _ckvmssts_noperl(sys$setast(0));
3045 if (!info->done) { /* Tap them gently on the shoulder . . .*/
3046 sts = sys$forcex(&info->pid,0,&abort);
3047 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3050 _ckvmssts_noperl(sys$setast(1));
3054 /* again, wait for effect */
3056 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3061 _ckvmssts_noperl(sys$setast(0));
3062 if (info->waiting && info->done)
3064 nwait += info->waiting;
3065 _ckvmssts_noperl(sys$setast(1));
3074 _ckvmssts_noperl(sys$setast(0));
3075 if (!info->done) { /* We tried to be nice . . . */
3076 sts = sys$delprc(&info->pid,0);
3077 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3078 info->done = 1; /* sys$delprc is as done as we're going to get. */
3080 _ckvmssts_noperl(sys$setast(1));
3086 #if defined(PERL_IMPLICIT_CONTEXT)
3087 /* We need to use the Perl context of the thread that created */
3090 if (open_pipes->err)
3091 aTHX = open_pipes->err->thx;
3092 else if (open_pipes->out)
3093 aTHX = open_pipes->out->thx;
3094 else if (open_pipes->in)
3095 aTHX = open_pipes->in->thx;
3097 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3098 else if (!(sts & 1)) retsts = sts;
3103 static struct exit_control_block pipe_exitblock =
3104 {(struct exit_control_block *) 0,
3105 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3107 static void pipe_mbxtofd_ast(pPipe p);
3108 static void pipe_tochild1_ast(pPipe p);
3109 static void pipe_tochild2_ast(pPipe p);
3112 popen_completion_ast(pInfo info)
3114 pInfo i = open_pipes;
3119 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3120 closed_list[closed_index].pid = info->pid;
3121 closed_list[closed_index].completion = info->completion;
3123 if (closed_index == NKEEPCLOSED)
3128 if (i == info) break;
3131 if (!i) return; /* unlinked, probably freed too */
3136 Writing to subprocess ...
3137 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3139 chan_out may be waiting for "done" flag, or hung waiting
3140 for i/o completion to child...cancel the i/o. This will
3141 put it into "snarf mode" (done but no EOF yet) that discards
3144 Output from subprocess (stdout, stderr) needs to be flushed and
3145 shut down. We try sending an EOF, but if the mbx is full the pipe
3146 routine should still catch the "shut_on_empty" flag, telling it to
3147 use immediate-style reads so that "mbx empty" -> EOF.
3151 if (info->in && !info->in_done) { /* only for mode=w */
3152 if (info->in->shut_on_empty && info->in->need_wake) {
3153 info->in->need_wake = FALSE;
3154 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3156 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3160 if (info->out && !info->out_done) { /* were we also piping output? */
3161 info->out->shut_on_empty = TRUE;
3162 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3163 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3164 _ckvmssts_noperl(iss);
3167 if (info->err && !info->err_done) { /* we were piping stderr */
3168 info->err->shut_on_empty = TRUE;
3169 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3170 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3171 _ckvmssts_noperl(iss);
3173 _ckvmssts_noperl(sys$setef(pipe_ef));
3177 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3178 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3181 we actually differ from vmstrnenv since we use this to
3182 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3183 are pointing to the same thing
3186 static unsigned short
3187 popen_translate(pTHX_ char *logical, char *result)
3190 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3191 $DESCRIPTOR(d_log,"");
3193 unsigned short length;
3194 unsigned short code;
3196 unsigned short *retlenaddr;
3198 unsigned short l, ifi;
3200 d_log.dsc$a_pointer = logical;
3201 d_log.dsc$w_length = strlen(logical);
3203 itmlst[0].code = LNM$_STRING;
3204 itmlst[0].length = 255;
3205 itmlst[0].buffer_addr = result;
3206 itmlst[0].retlenaddr = &l;
3209 itmlst[1].length = 0;
3210 itmlst[1].buffer_addr = 0;
3211 itmlst[1].retlenaddr = 0;
3213 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3214 if (iss == SS$_NOLOGNAM) {
3218 if (!(iss&1)) lib$signal(iss);
3221 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3222 strip it off and return the ifi, if any
3225 if (result[0] == 0x1b && result[1] == 0x00) {
3226 memmove(&ifi,result+2,2);
3227 strcpy(result,result+4);
3229 return ifi; /* this is the RMS internal file id */
3232 static void pipe_infromchild_ast(pPipe p);
3235 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3236 inside an AST routine without worrying about reentrancy and which Perl
3237 memory allocator is being used.
3239 We read data and queue up the buffers, then spit them out one at a
3240 time to the output mailbox when the output mailbox is ready for one.
3243 #define INITIAL_TOCHILDQUEUE 2
3246 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3250 char mbx1[64], mbx2[64];
3251 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3252 DSC$K_CLASS_S, mbx1},
3253 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3254 DSC$K_CLASS_S, mbx2};
3255 unsigned int dviitm = DVI$_DEVBUFSIZ;
3259 _ckvmssts_noperl(lib$get_vm(&n, &p));
3261 create_mbx(&p->chan_in , &d_mbx1);
3262 create_mbx(&p->chan_out, &d_mbx2);
3263 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3266 p->shut_on_empty = FALSE;
3267 p->need_wake = FALSE;
3270 p->iosb.status = SS$_NORMAL;
3271 p->iosb2.status = SS$_NORMAL;
3277 #ifdef PERL_IMPLICIT_CONTEXT
3281 n = sizeof(CBuf) + p->bufsize;
3283 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3284 _ckvmssts_noperl(lib$get_vm(&n, &b));
3285 b->buf = (char *) b + sizeof(CBuf);
3286 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3289 pipe_tochild2_ast(p);
3290 pipe_tochild1_ast(p);
3296 /* reads the MBX Perl is writing, and queues */
3299 pipe_tochild1_ast(pPipe p)
3302 int iss = p->iosb.status;
3303 int eof = (iss == SS$_ENDOFFILE);
3305 #ifdef PERL_IMPLICIT_CONTEXT
3311 p->shut_on_empty = TRUE;
3313 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3315 _ckvmssts_noperl(iss);
3319 b->size = p->iosb.count;
3320 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3322 p->need_wake = FALSE;
3323 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3326 p->retry = 1; /* initial call */
3329 if (eof) { /* flush the free queue, return when done */
3330 int n = sizeof(CBuf) + p->bufsize;
3332 iss = lib$remqti(&p->free, &b);
3333 if (iss == LIB$_QUEWASEMP) return;
3334 _ckvmssts_noperl(iss);
3335 _ckvmssts_noperl(lib$free_vm(&n, &b));
3339 iss = lib$remqti(&p->free, &b);
3340 if (iss == LIB$_QUEWASEMP) {
3341 int n = sizeof(CBuf) + p->bufsize;
3342 _ckvmssts_noperl(lib$get_vm(&n, &b));
3343 b->buf = (char *) b + sizeof(CBuf);
3345 _ckvmssts_noperl(iss);
3349 iss = sys$qio(0,p->chan_in,
3350 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3352 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3353 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3354 _ckvmssts_noperl(iss);
3358 /* writes queued buffers to output, waits for each to complete before
3362 pipe_tochild2_ast(pPipe p)
3365 int iss = p->iosb2.status;
3366 int n = sizeof(CBuf) + p->bufsize;
3367 int done = (p->info && p->info->done) ||
3368 iss == SS$_CANCEL || iss == SS$_ABORT;
3369 #if defined(PERL_IMPLICIT_CONTEXT)
3374 if (p->type) { /* type=1 has old buffer, dispose */
3375 if (p->shut_on_empty) {
3376 _ckvmssts_noperl(lib$free_vm(&n, &b));
3378 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3383 iss = lib$remqti(&p->wait, &b);
3384 if (iss == LIB$_QUEWASEMP) {
3385 if (p->shut_on_empty) {
3387 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3388 *p->pipe_done = TRUE;
3389 _ckvmssts_noperl(sys$setef(pipe_ef));
3391 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3392 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3396 p->need_wake = TRUE;
3399 _ckvmssts_noperl(iss);
3406 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3407 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3409 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3410 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3419 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3422 char mbx1[64], mbx2[64];
3423 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3424 DSC$K_CLASS_S, mbx1},
3425 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3426 DSC$K_CLASS_S, mbx2};
3427 unsigned int dviitm = DVI$_DEVBUFSIZ;
3429 int n = sizeof(Pipe);
3430 _ckvmssts_noperl(lib$get_vm(&n, &p));
3431 create_mbx(&p->chan_in , &d_mbx1);
3432 create_mbx(&p->chan_out, &d_mbx2);
3434 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3435 n = p->bufsize * sizeof(char);
3436 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3437 p->shut_on_empty = FALSE;
3440 p->iosb.status = SS$_NORMAL;
3441 #if defined(PERL_IMPLICIT_CONTEXT)
3444 pipe_infromchild_ast(p);
3452 pipe_infromchild_ast(pPipe p)
3454 int iss = p->iosb.status;
3455 int eof = (iss == SS$_ENDOFFILE);
3456 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3457 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3458 #if defined(PERL_IMPLICIT_CONTEXT)
3462 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3463 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3468 input shutdown if EOF from self (done or shut_on_empty)
3469 output shutdown if closing flag set (my_pclose)
3470 send data/eof from child or eof from self
3471 otherwise, re-read (snarf of data from child)
3476 if (myeof && p->chan_in) { /* input shutdown */
3477 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3482 if (myeof || kideof) { /* pass EOF to parent */
3483 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3484 pipe_infromchild_ast, p,
3487 } else if (eof) { /* eat EOF --- fall through to read*/
3489 } else { /* transmit data */
3490 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3491 pipe_infromchild_ast,p,
3492 p->buf, p->iosb.count, 0, 0, 0, 0));
3498 /* everything shut? flag as done */
3500 if (!p->chan_in && !p->chan_out) {
3501 *p->pipe_done = TRUE;
3502 _ckvmssts_noperl(sys$setef(pipe_ef));
3506 /* write completed (or read, if snarfing from child)
3507 if still have input active,
3508 queue read...immediate mode if shut_on_empty so we get EOF if empty
3510 check if Perl reading, generate EOFs as needed
3516 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3517 pipe_infromchild_ast,p,
3518 p->buf, p->bufsize, 0, 0, 0, 0);
3519 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3520 _ckvmssts_noperl(iss);
3521 } else { /* send EOFs for extra reads */
3522 p->iosb.status = SS$_ENDOFFILE;
3523 p->iosb.dvispec = 0;
3524 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3526 pipe_infromchild_ast, p, 0, 0, 0, 0));
3532 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3536 unsigned long dviitm = DVI$_DEVBUFSIZ;
3538 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3539 DSC$K_CLASS_S, mbx};
3540 int n = sizeof(Pipe);
3542 /* things like terminals and mbx's don't need this filter */
3543 if (fd && fstat(fd,&s) == 0) {
3544 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3546 unsigned short dev_len;
3547 struct dsc$descriptor_s d_dev;
3549 struct item_list_3 items[3];
3551 unsigned short dvi_iosb[4];
3553 cptr = getname(fd, out, 1);
3554 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3555 d_dev.dsc$a_pointer = out;
3556 d_dev.dsc$w_length = strlen(out);
3557 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3558 d_dev.dsc$b_class = DSC$K_CLASS_S;
3561 items[0].code = DVI$_DEVCHAR;
3562 items[0].bufadr = &devchar;
3563 items[0].retadr = NULL;
3565 items[1].code = DVI$_FULLDEVNAM;
3566 items[1].bufadr = device;
3567 items[1].retadr = &dev_len;
3571 status = sys$getdviw
3572 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3573 _ckvmssts_noperl(status);
3574 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3575 device[dev_len] = 0;
3577 if (!(devchar & DEV$M_DIR)) {
3578 strcpy(out, device);
3584 _ckvmssts_noperl(lib$get_vm(&n, &p));
3585 p->fd_out = dup(fd);
3586 create_mbx(&p->chan_in, &d_mbx);
3587 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3588 n = (p->bufsize+1) * sizeof(char);
3589 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3590 p->shut_on_empty = FALSE;
3595 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3596 pipe_mbxtofd_ast, p,
3597 p->buf, p->bufsize, 0, 0, 0, 0));
3603 pipe_mbxtofd_ast(pPipe p)
3605 int iss = p->iosb.status;
3606 int done = p->info->done;
3608 int eof = (iss == SS$_ENDOFFILE);
3609 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3610 int err = !(iss&1) && !eof;
3611 #if defined(PERL_IMPLICIT_CONTEXT)
3615 if (done && myeof) { /* end piping */
3617 sys$dassgn(p->chan_in);
3618 *p->pipe_done = TRUE;
3619 _ckvmssts_noperl(sys$setef(pipe_ef));
3623 if (!err && !eof) { /* good data to send to file */
3624 p->buf[p->iosb.count] = '\n';
3625 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3628 if (p->retry < MAX_RETRY) {
3629 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3635 _ckvmssts_noperl(iss);
3639 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3640 pipe_mbxtofd_ast, p,
3641 p->buf, p->bufsize, 0, 0, 0, 0);
3642 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3643 _ckvmssts_noperl(iss);
3647 typedef struct _pipeloc PLOC;
3648 typedef struct _pipeloc* pPLOC;
3652 char dir[NAM$C_MAXRSS+1];
3654 static pPLOC head_PLOC = 0;
3657 free_pipelocs(pTHX_ void *head)
3660 pPLOC *pHead = (pPLOC *)head;
3672 store_pipelocs(pTHX)
3681 char temp[NAM$C_MAXRSS+1];
3685 free_pipelocs(aTHX_ &head_PLOC);
3687 /* the . directory from @INC comes last */
3689 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3690 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3691 p->next = head_PLOC;
3693 strcpy(p->dir,"./");
3695 /* get the directory from $^X */
3697 unixdir = PerlMem_malloc(VMS_MAXRSS);
3698 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3700 #ifdef PERL_IMPLICIT_CONTEXT
3701 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3703 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3705 strcpy(temp, PL_origargv[0]);
3706 x = strrchr(temp,']');
3708 x = strrchr(temp,'>');
3710 /* It could be a UNIX path */
3711 x = strrchr(temp,'/');
3717 /* Got a bare name, so use default directory */
3722 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3723 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3724 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3725 p->next = head_PLOC;
3727 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3728 p->dir[NAM$C_MAXRSS] = '\0';
3732 /* reverse order of @INC entries, skip "." since entered above */
3734 #ifdef PERL_IMPLICIT_CONTEXT
3737 if (PL_incgv) av = GvAVn(PL_incgv);
3739 for (i = 0; av && i <= AvFILL(av); i++) {
3740 dirsv = *av_fetch(av,i,TRUE);
3742 if (SvROK(dirsv)) continue;
3743 dir = SvPVx(dirsv,n_a);
3744 if (strcmp(dir,".") == 0) continue;
3745 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3748 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3749 p->next = head_PLOC;
3751 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3752 p->dir[NAM$C_MAXRSS] = '\0';
3755 /* most likely spot (ARCHLIB) put first in the list */
3758 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3759 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3760 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3761 p->next = head_PLOC;
3763 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3764 p->dir[NAM$C_MAXRSS] = '\0';
3767 PerlMem_free(unixdir);
3771 Perl_cando_by_name_int
3772 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3773 #if !defined(PERL_IMPLICIT_CONTEXT)
3774 #define cando_by_name_int Perl_cando_by_name_int
3776 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3782 static int vmspipe_file_status = 0;
3783 static char vmspipe_file[NAM$C_MAXRSS+1];
3785 /* already found? Check and use ... need read+execute permission */
3787 if (vmspipe_file_status == 1) {
3788 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3789 && cando_by_name_int
3790 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3791 return vmspipe_file;
3793 vmspipe_file_status = 0;
3796 /* scan through stored @INC, $^X */
3798 if (vmspipe_file_status == 0) {
3799 char file[NAM$C_MAXRSS+1];
3800 pPLOC p = head_PLOC;
3805 strcpy(file, p->dir);
3806 dirlen = strlen(file);
3807 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3808 file[NAM$C_MAXRSS] = '\0';
3811 exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3812 if (!exp_res) continue;
3814 if (cando_by_name_int
3815 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3816 && cando_by_name_int
3817 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3818 vmspipe_file_status = 1;
3819 return vmspipe_file;
3822 vmspipe_file_status = -1; /* failed, use tempfiles */
3829 vmspipe_tempfile(pTHX)
3831 char file[NAM$C_MAXRSS+1];
3833 static int index = 0;
3837 /* create a tempfile */
3839 /* we can't go from W, shr=get to R, shr=get without
3840 an intermediate vulnerable state, so don't bother trying...
3842 and lib$spawn doesn't shr=put, so have to close the write
3844 So... match up the creation date/time and the FID to
3845 make sure we're dealing with the same file
3850 if (!decc_filename_unix_only) {
3851 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3852 fp = fopen(file,"w");
3854 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3855 fp = fopen(file,"w");
3857 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3858 fp = fopen(file,"w");
3863 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3864 fp = fopen(file,"w");
3866 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3867 fp = fopen(file,"w");
3869 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3870 fp = fopen(file,"w");
3874 if (!fp) return 0; /* we're hosed */
3876 fprintf(fp,"$! 'f$verify(0)'\n");
3877 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3878 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3879 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3880 fprintf(fp,"$ perl_on = \"set noon\"\n");
3881 fprintf(fp,"$ perl_exit = \"exit\"\n");
3882 fprintf(fp,"$ perl_del = \"delete\"\n");
3883 fprintf(fp,"$ pif = \"if\"\n");
3884 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3885 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3886 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3887 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3888 fprintf(fp,"$! --- build command line to get max possible length\n");
3889 fprintf(fp,"$c=perl_popen_cmd0\n");
3890 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3891 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3892 fprintf(fp,"$x=perl_popen_cmd3\n");
3893 fprintf(fp,"$c=c+x\n");
3894 fprintf(fp,"$ perl_on\n");
3895 fprintf(fp,"$ 'c'\n");
3896 fprintf(fp,"$ perl_status = $STATUS\n");
3897 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3898 fprintf(fp,"$ perl_exit 'perl_status'\n");
3901 fgetname(fp, file, 1);
3902 fstat(fileno(fp), (struct stat *)&s0);
3905 if (decc_filename_unix_only)
3906 int_tounixspec(file, file, NULL);
3907 fp = fopen(file,"r","shr=get");
3909 fstat(fileno(fp), (struct stat *)&s1);
3911 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3912 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3921 static int vms_is_syscommand_xterm(void)
3923 const static struct dsc$descriptor_s syscommand_dsc =
3924 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3926 const static struct dsc$descriptor_s decwdisplay_dsc =
3927 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3929 struct item_list_3 items[2];
3930 unsigned short dvi_iosb[4];
3931 unsigned long devchar;
3932 unsigned long devclass;
3935 /* Very simple check to guess if sys$command is a decterm? */
3936 /* First see if the DECW$DISPLAY: device exists */
3938 items[0].code = DVI$_DEVCHAR;
3939 items[0].bufadr = &devchar;
3940 items[0].retadr = NULL;
3944 status = sys$getdviw
3945 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3947 if ($VMS_STATUS_SUCCESS(status)) {
3948 status = dvi_iosb[0];
3951 if (!$VMS_STATUS_SUCCESS(status)) {
3952 SETERRNO(EVMSERR, status);
3956 /* If it does, then for now assume that we are on a workstation */
3957 /* Now verify that SYS$COMMAND is a terminal */
3958 /* for creating the debugger DECTerm */
3961 items[0].code = DVI$_DEVCLASS;
3962 items[0].bufadr = &devclass;
3963 items[0].retadr = NULL;
3967 status = sys$getdviw
3968 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3970 if ($VMS_STATUS_SUCCESS(status)) {
3971 status = dvi_iosb[0];
3974 if (!$VMS_STATUS_SUCCESS(status)) {
3975 SETERRNO(EVMSERR, status);
3979 if (devclass == DC$_TERM) {
3986 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3987 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3992 char device_name[65];
3993 unsigned short device_name_len;
3994 struct dsc$descriptor_s customization_dsc;
3995 struct dsc$descriptor_s device_name_dsc;
3998 char customization[200];
4002 unsigned short p_chan;
4004 unsigned short iosb[4];
4005 struct item_list_3 items[2];
4006 const char * cust_str =
4007 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4008 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4009 DSC$K_CLASS_S, mbx1};
4011 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4012 /*---------------------------------------*/
4013 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4016 /* Make sure that this is from the Perl debugger */
4017 ret_char = strstr(cmd," xterm ");
4018 if (ret_char == NULL)
4020 cptr = ret_char + 7;
4021 ret_char = strstr(cmd,"tty");
4022 if (ret_char == NULL)
4024 ret_char = strstr(cmd,"sleep");
4025 if (ret_char == NULL)
4028 if (decw_term_port == 0) {
4029 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4030 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4031 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4033 status = lib$find_image_symbol
4035 &decw_term_port_dsc,
4036 (void *)&decw_term_port,
4040 /* Try again with the other image name */
4041 if (!$VMS_STATUS_SUCCESS(status)) {
4043 status = lib$find_image_symbol
4045 &decw_term_port_dsc,
4046 (void *)&decw_term_port,
4055 /* No decw$term_port, give it up */
4056 if (!$VMS_STATUS_SUCCESS(status))
4059 /* Are we on a workstation? */
4060 /* to do: capture the rows / columns and pass their properties */
4061 ret_stat = vms_is_syscommand_xterm();
4065 /* Make the title: */
4066 ret_char = strstr(cptr,"-title");
4067 if (ret_char != NULL) {
4068 while ((*cptr != 0) && (*cptr != '\"')) {
4074 while ((*cptr != 0) && (*cptr != '\"')) {
4087 strcpy(title,"Perl Debug DECTerm");
4089 sprintf(customization, cust_str, title);
4091 customization_dsc.dsc$a_pointer = customization;
4092 customization_dsc.dsc$w_length = strlen(customization);
4093 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4094 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4096 device_name_dsc.dsc$a_pointer = device_name;
4097 device_name_dsc.dsc$w_length = sizeof device_name -1;
4098 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4099 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4101 device_name_len = 0;
4103 /* Try to create the window */
4104 status = (*decw_term_port)
4113 if (!$VMS_STATUS_SUCCESS(status)) {
4114 SETERRNO(EVMSERR, status);
4118 device_name[device_name_len] = '\0';
4120 /* Need to set this up to look like a pipe for cleanup */
4122 status = lib$get_vm(&n, &info);
4123 if (!$VMS_STATUS_SUCCESS(status)) {
4124 SETERRNO(ENOMEM, status);
4130 info->completion = 0;
4131 info->closing = FALSE;
4138 info->in_done = TRUE;
4139 info->out_done = TRUE;
4140 info->err_done = TRUE;
4142 /* Assign a channel on this so that it will persist, and not login */
4143 /* We stash this channel in the info structure for reference. */
4144 /* The created xterm self destructs when the last channel is removed */
4145 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4146 /* So leave this assigned. */
4147 device_name_dsc.dsc$w_length = device_name_len;
4148 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4149 if (!$VMS_STATUS_SUCCESS(status)) {
4150 SETERRNO(EVMSERR, status);
4153 info->xchan_valid = 1;
4155 /* Now create a mailbox to be read by the application */
4157 create_mbx(&p_chan, &d_mbx1);
4159 /* write the name of the created terminal to the mailbox */
4160 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4161 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4163 if (!$VMS_STATUS_SUCCESS(status)) {
4164 SETERRNO(EVMSERR, status);
4168 info->fp = PerlIO_open(mbx1, mode);
4170 /* Done with this channel */
4173 /* If any errors, then clean up */
4176 _ckvmssts_noperl(lib$free_vm(&n, &info));
4184 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4187 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4189 static int handler_set_up = FALSE;
4191 unsigned long int sts, flags = CLI$M_NOWAIT;
4192 /* The use of a GLOBAL table (as was done previously) rendered
4193 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4194 * environment. Hence we've switched to LOCAL symbol table.
4196 unsigned int table = LIB$K_CLI_LOCAL_SYM;
4198 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4199 char *in, *out, *err, mbx[512];
4201 char tfilebuf[NAM$C_MAXRSS+1];
4203 char cmd_sym_name[20];
4204 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4205 DSC$K_CLASS_S, symbol};
4206 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4208 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4209 DSC$K_CLASS_S, cmd_sym_name};
4210 struct dsc$descriptor_s *vmscmd;
4211 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4212 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4213 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4215 /* Check here for Xterm create request. This means looking for
4216 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4217 * is possible to create an xterm.
4219 if (*in_mode == 'r') {
4222 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4223 if (xterm_fd != NULL)
4227 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4229 /* once-per-program initialization...
4230 note that the SETAST calls and the dual test of pipe_ef
4231 makes sure that only the FIRST thread through here does
4232 the initialization...all other threads wait until it's
4235 Yeah, uglier than a pthread call, it's got all the stuff inline
4236 rather than in a separate routine.
4240 _ckvmssts_noperl(sys$setast(0));
4242 unsigned long int pidcode = JPI$_PID;
4243 $DESCRIPTOR(d_delay, RETRY_DELAY);
4244 _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4245 _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4246 _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4248 if (!handler_set_up) {
4249 _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4250 handler_set_up = TRUE;
4252 _ckvmssts_noperl(sys$setast(1));
4255 /* see if we can find a VMSPIPE.COM */
4258 vmspipe = find_vmspipe(aTHX);
4260 strcpy(tfilebuf+1,vmspipe);
4261 } else { /* uh, oh...we're in tempfile hell */
4262 tpipe = vmspipe_tempfile(aTHX);
4263 if (!tpipe) { /* a fish popular in Boston */
4264 if (ckWARN(WARN_PIPE)) {
4265 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4269 fgetname(tpipe,tfilebuf+1,1);
4271 vmspipedsc.dsc$a_pointer = tfilebuf;
4272 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4274 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4277 case RMS$_FNF: case RMS$_DNF:
4278 set_errno(ENOENT); break;
4280 set_errno(ENOTDIR); break;
4282 set_errno(ENODEV); break;
4284 set_errno(EACCES); break;
4286 set_errno(EINVAL); break;
4287 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4288 set_errno(E2BIG); break;
4289 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4290 _ckvmssts_noperl(sts); /* fall through */
4291 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4294 set_vaxc_errno(sts);
4295 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4296 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4302 _ckvmssts_noperl(lib$get_vm(&n, &info));
4304 strcpy(mode,in_mode);
4307 info->completion = 0;
4308 info->closing = FALSE;
4315 info->in_done = TRUE;
4316 info->out_done = TRUE;
4317 info->err_done = TRUE;
4319 info->xchan_valid = 0;
4321 in = PerlMem_malloc(VMS_MAXRSS);
4322 if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4323 out = PerlMem_malloc(VMS_MAXRSS);
4324 if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4325 err = PerlMem_malloc(VMS_MAXRSS);
4326 if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4328 in[0] = out[0] = err[0] = '\0';
4330 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4334 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4339 if (*mode == 'r') { /* piping from subroutine */
4341 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4343 info->out->pipe_done = &info->out_done;
4344 info->out_done = FALSE;
4345 info->out->info = info;
4347 if (!info->useFILE) {
4348 info->fp = PerlIO_open(mbx, mode);
4350 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4351 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4354 if (!info->fp && info->out) {
4355 sys$cancel(info->out->chan_out);
4357 while (!info->out_done) {
4359 _ckvmssts_noperl(sys$setast(0));
4360 done = info->out_done;
4361 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4362 _ckvmssts_noperl(sys$setast(1));
4363 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4366 if (info->out->buf) {
4367 n = info->out->bufsize * sizeof(char);
4368 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4371 _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4373 _ckvmssts_noperl(lib$free_vm(&n, &info));
4378 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4380 info->err->pipe_done = &info->err_done;
4381 info->err_done = FALSE;
4382 info->err->info = info;
4385 } else if (*mode == 'w') { /* piping to subroutine */
4387 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4389 info->out->pipe_done = &info->out_done;
4390 info->out_done = FALSE;
4391 info->out->info = info;
4394 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4396 info->err->pipe_done = &info->err_done;
4397 info->err_done = FALSE;
4398 info->err->info = info;
4401 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4402 if (!info->useFILE) {
4403 info->fp = PerlIO_open(mbx, mode);
4405 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4406 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4410 info->in->pipe_done = &info->in_done;
4411 info->in_done = FALSE;
4412 info->in->info = info;
4416 if (!info->fp && info->in) {
4418 _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4419 0, 0, 0, 0, 0, 0, 0, 0));
4421 while (!info->in_done) {
4423 _ckvmssts_noperl(sys$setast(0));
4424 done = info->in_done;
4425 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4426 _ckvmssts_noperl(sys$setast(1));
4427 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4430 if (info->in->buf) {
4431 n = info->in->bufsize * sizeof(char);
4432 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4435 _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4437 _ckvmssts_noperl(lib$free_vm(&n, &info));
4443 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4444 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4446 info->out->pipe_done = &info->out_done;
4447 info->out_done = FALSE;
4448 info->out->info = info;
4451 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4453 info->err->pipe_done = &info->err_done;
4454 info->err_done = FALSE;
4455 info->err->info = info;
4459 symbol[MAX_DCL_SYMBOL] = '\0';
4461 strncpy(symbol, in, MAX_DCL_SYMBOL);
4462 d_symbol.dsc$w_length = strlen(symbol);
4463 _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4465 strncpy(symbol, err, MAX_DCL_SYMBOL);
4466 d_symbol.dsc$w_length = strlen(symbol);
4467 _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4469 strncpy(symbol, out, MAX_DCL_SYMBOL);
4470 d_symbol.dsc$w_length = strlen(symbol);
4471 _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4473 /* Done with the names for the pipes */
4478 p = vmscmd->dsc$a_pointer;
4479 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4480 if (*p == '$') p++; /* remove leading $ */
4481 while (*p == ' ' || *p == '\t') p++;
4483 for (j = 0; j < 4; j++) {
4484 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4485 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4487 strncpy(symbol, p, MAX_DCL_SYMBOL);
4488 d_symbol.dsc$w_length = strlen(symbol);
4489 _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4491 if (strlen(p) > MAX_DCL_SYMBOL) {
4492 p += MAX_DCL_SYMBOL;
4497 _ckvmssts_noperl(sys$setast(0));
4498 info->next=open_pipes; /* prepend to list */
4500 _ckvmssts_noperl(sys$setast(1));
4501 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4502 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4503 * have SYS$COMMAND if we need it.
4505 _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4506 0, &info->pid, &info->completion,
4507 0, popen_completion_ast,info,0,0,0));
4509 /* if we were using a tempfile, close it now */
4511 if (tpipe) fclose(tpipe);
4513 /* once the subprocess is spawned, it has copied the symbols and
4514 we can get rid of ours */
4516 for (j = 0; j < 4; j++) {
4517 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4518 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4519 _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4521 _ckvmssts_noperl(lib$delete_symbol(&d_sym_in, &table));
4522 _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4523 _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4524 vms_execfree(vmscmd);
4526 #ifdef PERL_IMPLICIT_CONTEXT
4529 PL_forkprocess = info->pid;
4536 _ckvmssts_noperl(sys$setast(0));
4538 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4539 _ckvmssts_noperl(sys$setast(1));
4540 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4542 *psts = info->completion;
4543 /* Caller thinks it is open and tries to close it. */
4544 /* This causes some problems, as it changes the error status */
4545 /* my_pclose(info->fp); */
4547 /* If we did not have a file pointer open, then we have to */
4548 /* clean up here or eventually we will run out of something */
4550 if (info->fp == NULL) {
4551 my_pclose_pinfo(aTHX_ info);
4559 } /* end of safe_popen */
4562 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4564 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4568 TAINT_PROPER("popen");
4569 PERL_FLUSHALL_FOR_CHILD;
4570 return safe_popen(aTHX_ cmd,mode,&sts);
4576 /* Routine to close and cleanup a pipe info structure */
4578 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4580 unsigned long int retsts;
4585 /* If we were writing to a subprocess, insure that someone reading from
4586 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4587 * produce an EOF record in the mailbox.
4589 * well, at least sometimes it *does*, so we have to watch out for
4590 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4594 #if defined(USE_ITHREADS)
4597 && PL_perlio_fd_refcnt)
4598 PerlIO_flush(info->fp);
4600 fflush((FILE *)info->fp);
4603 _ckvmssts(sys$setast(0));
4604 info->closing = TRUE;
4605 done = info->done && info->in_done && info->out_done && info->err_done;
4606 /* hanging on write to Perl's input? cancel it */
4607 if (info->mode == 'r' && info->out && !info->out_done) {
4608 if (info->out->chan_out) {
4609 _ckvmssts(sys$cancel(info->out->chan_out));
4610 if (!info->out->chan_in) { /* EOF generation, need AST */
4611 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4615 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4616 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4618 _ckvmssts(sys$setast(1));
4621 #if defined(USE_ITHREADS)
4624 && PL_perlio_fd_refcnt)
4625 PerlIO_close(info->fp);
4627 fclose((FILE *)info->fp);
4630 we have to wait until subprocess completes, but ALSO wait until all
4631 the i/o completes...otherwise we'll be freeing the "info" structure
4632 that the i/o ASTs could still be using...
4636 _ckvmssts(sys$setast(0));
4637 done = info->done && info->in_done && info->out_done && info->err_done;
4638 if (!done) _ckvmssts(sys$clref(pipe_ef));
4639 _ckvmssts(sys$setast(1));
4640 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4642 retsts = info->completion;
4644 /* remove from list of open pipes */
4645 _ckvmssts(sys$setast(0));
4647 for (next = open_pipes; next != NULL; last = next, next = next->next) {
4653 last->next = info->next;
4655 open_pipes = info->next;
4656 _ckvmssts(sys$setast(1));
4658 /* free buffers and structures */
4661 if (info->in->buf) {
4662 n = info->in->bufsize * sizeof(char);
4663 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4666 _ckvmssts(lib$free_vm(&n, &info->in));
4669 if (info->out->buf) {
4670 n = info->out->bufsize * sizeof(char);
4671 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4674 _ckvmssts(lib$free_vm(&n, &info->out));
4677 if (info->err->buf) {
4678 n = info->err->bufsize * sizeof(char);
4679 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4682 _ckvmssts(lib$free_vm(&n, &info->err));
4685 _ckvmssts(lib$free_vm(&n, &info));
4691 /*{{{ I32 my_pclose(PerlIO *fp)*/
4692 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4694 pInfo info, last = NULL;
4697 /* Fixme - need ast and mutex protection here */
4698 for (info = open_pipes; info != NULL; last = info, info = info->next)
4699 if (info->fp == fp) break;
4701 if (info == NULL) { /* no such pipe open */
4702 set_errno(ECHILD); /* quoth POSIX */
4703 set_vaxc_errno(SS$_NONEXPR);
4707 ret_status = my_pclose_pinfo(aTHX_ info);
4711 } /* end of my_pclose() */
4713 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4714 /* Roll our own prototype because we want this regardless of whether
4715 * _VMS_WAIT is defined.
4717 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4719 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4720 created with popen(); otherwise partially emulate waitpid() unless
4721 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4722 Also check processes not considered by the CRTL waitpid().
4724 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4726 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4733 if (statusp) *statusp = 0;
4735 for (info = open_pipes; info != NULL; info = info->next)
4736 if (info->pid == pid) break;
4738 if (info != NULL) { /* we know about this child */
4739 while (!info->done) {
4740 _ckvmssts(sys$setast(0));
4742 if (!done) _ckvmssts(sys$clref(pipe_ef));
4743 _ckvmssts(sys$setast(1));
4744 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4747 if (statusp) *statusp = info->completion;
4751 /* child that already terminated? */
4753 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4754 if (closed_list[j].pid == pid) {
4755 if (statusp) *statusp = closed_list[j].completion;
4760 /* fall through if this child is not one of our own pipe children */
4762 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4764 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4765 * in 7.2 did we get a version that fills in the VMS completion
4766 * status as Perl has always tried to do.
4769 sts = __vms_waitpid( pid, statusp, flags );
4771 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4774 /* If the real waitpid tells us the child does not exist, we
4775 * fall through here to implement waiting for a child that
4776 * was created by some means other than exec() (say, spawned
4777 * from DCL) or to wait for a process that is not a subprocess
4778 * of the current process.
4781 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4784 $DESCRIPTOR(intdsc,"0 00:00:01");
4785 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4786 unsigned long int pidcode = JPI$_PID, mypid;
4787 unsigned long int interval[2];
4788 unsigned int jpi_iosb[2];
4789 struct itmlst_3 jpilist[2] = {
4790 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4795 /* Sorry folks, we don't presently implement rooting around for
4796 the first child we can find, and we definitely don't want to
4797 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4803 /* Get the owner of the child so I can warn if it's not mine. If the
4804 * process doesn't exist or I don't have the privs to look at it,
4805 * I can go home early.
4807 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4808 if (sts & 1) sts = jpi_iosb[0];
4820 set_vaxc_errno(sts);
4824 if (ckWARN(WARN_EXEC)) {
4825 /* remind folks they are asking for non-standard waitpid behavior */
4826 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4827 if (ownerpid != mypid)
4828 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4829 "waitpid: process %x is not a child of process %x",
4833 /* simply check on it once a second until it's not there anymore. */
4835 _ckvmssts(sys$bintim(&intdsc,interval));
4836 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4837 _ckvmssts(sys$schdwk(0,0,interval,0));
4838 _ckvmssts(sys$hiber());
4840 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4845 } /* end of waitpid() */
4850 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4852 my_gconvert(double val, int ndig, int trail, char *buf)
4854 static char __gcvtbuf[DBL_DIG+1];
4857 loc = buf ? buf : __gcvtbuf;
4859 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4861 sprintf(loc,"%.*g",ndig,val);
4867 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4868 return gcvt(val,ndig,loc);
4871 loc[0] = '0'; loc[1] = '\0';
4878 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4879 static int rms_free_search_context(struct FAB * fab)
4883 nam = fab->fab$l_nam;
4884 nam->nam$b_nop |= NAM$M_SYNCHK;
4885 nam->nam$l_rlf = NULL;
4887 return sys$parse(fab, NULL, NULL);
4890 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4891 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4892 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4893 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4894 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4895 #define rms_nam_esll(nam) nam.nam$b_esl
4896 #define rms_nam_esl(nam) nam.nam$b_esl
4897 #define rms_nam_name(nam) nam.nam$l_name
4898 #define rms_nam_namel(nam) nam.nam$l_name
4899 #define rms_nam_type(nam) nam.nam$l_type
4900 #define rms_nam_typel(nam) nam.nam$l_type
4901 #define rms_nam_ver(nam) nam.nam$l_ver
4902 #define rms_nam_verl(nam) nam.nam$l_ver
4903 #define rms_nam_rsll(nam) nam.nam$b_rsl
4904 #define rms_nam_rsl(nam) nam.nam$b_rsl
4905 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4906 #define rms_set_fna(fab, nam, name, size) \
4907 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4908 #define rms_get_fna(fab, nam) fab.fab$l_fna
4909 #define rms_set_dna(fab, nam, name, size) \
4910 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4911 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4912 #define rms_set_esa(nam, name, size) \
4913 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4914 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4915 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4916 #define rms_set_rsa(nam, name, size) \
4917 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4918 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4919 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4920 #define rms_nam_name_type_l_size(nam) \
4921 (nam.nam$b_name + nam.nam$b_type)
4923 static int rms_free_search_context(struct FAB * fab)
4927 nam = fab->fab$l_naml;
4928 nam->naml$b_nop |= NAM$M_SYNCHK;
4929 nam->naml$l_rlf = NULL;
4930 nam->naml$l_long_defname_size = 0;
4933 return sys$parse(fab, NULL, NULL);
4936 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4937 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4938 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4939 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4940 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4941 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4942 #define rms_nam_esl(nam) nam.naml$b_esl
4943 #define rms_nam_name(nam) nam.naml$l_name
4944 #define rms_nam_namel(nam) nam.naml$l_long_name
4945 #define rms_nam_type(nam) nam.naml$l_type
4946 #define rms_nam_typel(nam) nam.naml$l_long_type
4947 #define rms_nam_ver(nam) nam.naml$l_ver
4948 #define rms_nam_verl(nam) nam.naml$l_long_ver
4949 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4950 #define rms_nam_rsl(nam) nam.naml$b_rsl
4951 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4952 #define rms_set_fna(fab, nam, name, size) \
4953 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4954 nam.naml$l_long_filename_size = size; \
4955 nam.naml$l_long_filename = name;}
4956 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4957 #define rms_set_dna(fab, nam, name, size) \
4958 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4959 nam.naml$l_long_defname_size = size; \
4960 nam.naml$l_long_defname = name; }
4961 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4962 #define rms_set_esa(nam, name, size) \
4963 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4964 nam.naml$l_long_expand_alloc = size; \
4965 nam.naml$l_long_expand = name; }
4966 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4967 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4968 nam.naml$l_long_expand = l_name; \
4969 nam.naml$l_long_expand_alloc = l_size; }
4970 #define rms_set_rsa(nam, name, size) \
4971 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4972 nam.naml$l_long_result = name; \
4973 nam.naml$l_long_result_alloc = size; }
4974 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4975 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4976 nam.naml$l_long_result = l_name; \
4977 nam.naml$l_long_result_alloc = l_size; }
4978 #define rms_nam_name_type_l_size(nam) \
4979 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4984 * The CRTL for 8.3 and later can create symbolic links in any mode,
4985 * however in 8.3 the unlink/remove/delete routines will only properly handle
4986 * them if one of the PCP modes is active.
4988 static int rms_erase(const char * vmsname)
4991 struct FAB myfab = cc$rms_fab;
4992 rms_setup_nam(mynam);
4994 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4995 rms_bind_fab_nam(myfab, mynam);
4997 /* Are we removing all versions? */
4998 if (vms_unlink_all_versions == 1) {
4999 const char * defspec = ";*";
5000 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5003 #ifdef NAML$M_OPEN_SPECIAL
5004 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5007 status = sys$erase(&myfab, 0, 0);
5014 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5015 const struct dsc$descriptor_s * vms_dst_dsc,
5016 unsigned long flags)
5018 /* VMS and UNIX handle file permissions differently and the
5019 * the same ACL trick may be needed for renaming files,
5020 * especially if they are directories.
5023 /* todo: get kill_file and rename to share common code */
5024 /* I can not find online documentation for $change_acl
5025 * it appears to be replaced by $set_security some time ago */
5027 const unsigned int access_mode = 0;
5028 $DESCRIPTOR(obj_file_dsc,"FILE");
5031 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5032 int aclsts, fndsts, rnsts = -1;
5033 unsigned int ctx = 0;
5034 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5035 struct dsc$descriptor_s * clean_dsc;
5038 unsigned char myace$b_length;
5039 unsigned char myace$b_type;
5040 unsigned short int myace$w_flags;
5041 unsigned long int myace$l_access;
5042 unsigned long int myace$l_ident;
5043 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5044 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5046 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5049 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5050 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5052 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5053 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5057 /* Expand the input spec using RMS, since we do not want to put
5058 * ACLs on the target of a symbolic link */
5059 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5060 if (vmsname == NULL)
5063 rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5065 PERL_RMSEXPAND_M_SYMLINK);
5067 PerlMem_free(vmsname);
5071 /* So we get our own UIC to use as a rights identifier,
5072 * and the insert an ACE at the head of the ACL which allows us
5073 * to delete the file.
5075 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5077 fildsc.dsc$w_length = strlen(vmsname);
5078 fildsc.dsc$a_pointer = vmsname;
5080 newace.myace$l_ident = oldace.myace$l_ident;
5083 /* Grab any existing ACEs with this identifier in case we fail */
5084 clean_dsc = &fildsc;
5085 aclsts = fndsts = sys$get_security(&obj_file_dsc,
5093 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
5094 /* Add the new ACE . . . */
5096 /* if the sys$get_security succeeded, then ctx is valid, and the
5097 * object/file descriptors will be ignored. But otherwise they
5100 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5101 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5102 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5104 set_vaxc_errno(aclsts);
5105 PerlMem_free(vmsname);
5109 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5112 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5114 if ($VMS_STATUS_SUCCESS(rnsts)) {
5115 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5118 /* Put things back the way they were. */
5120 aclsts = sys$get_security(&obj_file_dsc,
5128 if ($VMS_STATUS_SUCCESS(aclsts)) {
5132 if (!$VMS_STATUS_SUCCESS(fndsts))
5133 sec_flags = OSS$M_RELCTX;
5135 /* Get rid of the new ACE */
5136 aclsts = sys$set_security(NULL, NULL, NULL,
5137 sec_flags, dellst, &ctx, &access_mode);
5139 /* If there was an old ACE, put it back */
5140 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5141 addlst[0].bufadr = &oldace;
5142 aclsts = sys$set_security(NULL, NULL, NULL,
5143 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5144 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5146 set_vaxc_errno(aclsts);
5152 /* Try to clear the lock on the ACL list */
5153 aclsts2 = sys$set_security(NULL, NULL, NULL,
5154 OSS$M_RELCTX, NULL, &ctx, &access_mode);
5156 /* Rename errors are most important */
5157 if (!$VMS_STATUS_SUCCESS(rnsts))
5160 set_vaxc_errno(aclsts);
5165 if (aclsts != SS$_ACLEMPTY)
5172 PerlMem_free(vmsname);
5177 /*{{{int rename(const char *, const char * */
5178 /* Not exactly what X/Open says to do, but doing it absolutely right
5179 * and efficiently would require a lot more work. This should be close
5180 * enough to pass all but the most strict X/Open compliance test.
5183 Perl_rename(pTHX_ const char *src, const char * dst)
5192 /* Validate the source file */
5193 src_sts = flex_lstat(src, &src_st);
5196 /* No source file or other problem */
5200 dst_sts = flex_lstat(dst, &dst_st);
5203 if (dst_st.st_dev != src_st.st_dev) {
5204 /* Must be on the same device */
5209 /* VMS_INO_T_COMPARE is true if the inodes are different
5210 * to match the output of memcmp
5213 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5214 /* That was easy, the files are the same! */
5218 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5219 /* If source is a directory, so must be dest */
5227 if ((dst_sts == 0) &&
5228 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5230 /* We have issues here if vms_unlink_all_versions is set
5231 * If the destination exists, and is not a directory, then
5232 * we must delete in advance.
5234 * If the src is a directory, then we must always pre-delete
5237 * If we successfully delete the dst in advance, and the rename fails
5238 * X/Open requires that errno be EIO.
5242 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5244 d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5248 /* We killed the destination, so only errno now is EIO */
5253 /* Originally the idea was to call the CRTL rename() and only
5254 * try the lib$rename_file if it failed.
5255 * It turns out that there are too many variants in what the
5256 * the CRTL rename might do, so only use lib$rename_file
5261 /* Is the source and dest both in VMS format */
5262 /* if the source is a directory, then need to fileify */
5263 /* and dest must be a directory or non-existant. */
5269 unsigned long flags;
5270 struct dsc$descriptor_s old_file_dsc;
5271 struct dsc$descriptor_s new_file_dsc;
5273 /* We need to modify the src and dst depending
5274 * on if one or more of them are directories.
5277 vms_src = PerlMem_malloc(VMS_MAXRSS);
5278 if (vms_src == NULL)
5279 _ckvmssts_noperl(SS$_INSFMEM);
5281 /* Source is always a VMS format file */
5282 ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5283 if (ret_str == NULL) {
5284 PerlMem_free(vms_src);
5289 vms_dst = PerlMem_malloc(VMS_MAXRSS);
5290 if (vms_dst == NULL)
5291 _ckvmssts_noperl(SS$_INSFMEM);
5293 if (S_ISDIR(src_st.st_mode)) {
5295 char * vms_dir_file;
5297 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5298 if (vms_dir_file == NULL)
5299 _ckvmssts_noperl(SS$_INSFMEM);
5301 /* The source must be a file specification */
5302 ret_str = int_fileify_dirspec(vms_src, vms_dir_file, NULL);
5303 if (ret_str == NULL) {
5304 PerlMem_free(vms_src);
5305 PerlMem_free(vms_dst);
5306 PerlMem_free(vms_dir_file);
5310 PerlMem_free(vms_src);
5311 vms_src = vms_dir_file;
5313 /* If the dest is a directory, we must remove it
5316 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5318 PerlMem_free(vms_src);
5319 PerlMem_free(vms_dst);
5327 /* The dest must be a VMS file specification */
5328 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5329 if (ret_str == NULL) {
5330 PerlMem_free(vms_src);
5331 PerlMem_free(vms_dst);
5336 /* The source must be a file specification */
5337 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5338 if (vms_dir_file == NULL)
5339 _ckvmssts_noperl(SS$_INSFMEM);
5341 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5342 if (ret_str == NULL) {
5343 PerlMem_free(vms_src);
5344 PerlMem_free(vms_dst);
5345 PerlMem_free(vms_dir_file);
5349 PerlMem_free(vms_dst);
5350 vms_dst = vms_dir_file;
5353 /* File to file or file to new dir */
5355 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5356 /* VMS pathify a dir target */
5357 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5358 if (ret_str == NULL) {
5359 PerlMem_free(vms_src);
5360 PerlMem_free(vms_dst);
5366 /* fileify a target VMS file specification */
5367 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5368 if (ret_str == NULL) {
5369 PerlMem_free(vms_src);
5370 PerlMem_free(vms_dst);
5377 old_file_dsc.dsc$a_pointer = vms_src;
5378 old_file_dsc.dsc$w_length = strlen(vms_src);
5379 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5380 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5382 new_file_dsc.dsc$a_pointer = vms_dst;
5383 new_file_dsc.dsc$w_length = strlen(vms_dst);
5384 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5385 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5388 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5389 flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5392 sts = lib$rename_file(&old_file_dsc,
5396 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5397 if (!$VMS_STATUS_SUCCESS(sts)) {
5399 /* We could have failed because VMS style permissions do not
5400 * permit renames that UNIX will allow. Just like the hack
5403 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5406 PerlMem_free(vms_src);
5407 PerlMem_free(vms_dst);
5408 if (!$VMS_STATUS_SUCCESS(sts)) {
5415 if (vms_unlink_all_versions) {
5416 /* Now get rid of any previous versions of the source file that
5421 src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5425 /* We deleted the destination, so must force the error to be EIO */
5426 if ((retval != 0) && (pre_delete != 0))
5434 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5435 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5436 * to expand file specification. Allows for a single default file
5437 * specification and a simple mask of options. If outbuf is non-NULL,
5438 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5439 * the resultant file specification is placed. If outbuf is NULL, the
5440 * resultant file specification is placed into a static buffer.
5441 * The third argument, if non-NULL, is taken to be a default file
5442 * specification string. The fourth argument is unused at present.
5443 * rmesexpand() returns the address of the resultant string if
5444 * successful, and NULL on error.
5446 * New functionality for previously unused opts value:
5447 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5448 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5449 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5450 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5452 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5456 (const char *filespec,
5458 const char *defspec,
5464 const char * in_spec;
5466 const char * def_spec;
5467 char * vmsfspec, *vmsdefspec;
5471 struct FAB myfab = cc$rms_fab;
5472 rms_setup_nam(mynam);
5474 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5477 /* temp hack until UTF8 is actually implemented */
5478 if (fs_utf8 != NULL)
5481 if (!filespec || !*filespec) {
5482 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5492 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5493 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5494 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5496 /* If this is a UNIX file spec, convert it to VMS */
5497 sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5498 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5499 &e_len, &vs_spec, &vs_len);
5504 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5505 if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5506 ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5507 if (ret_spec == NULL) {
5508 PerlMem_free(vmsfspec);
5511 in_spec = (const char *)vmsfspec;
5513 /* Unless we are forcing to VMS format, a UNIX input means
5514 * UNIX output, and that requires long names to be used
5516 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5517 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5518 opts |= PERL_RMSEXPAND_M_LONG;
5526 rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5527 rms_bind_fab_nam(myfab, mynam);
5529 /* Process the default file specification if present */
5531 if (defspec && *defspec) {
5533 t_isunix = is_unix_filespec(defspec);
5535 vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5536 if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5537 ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5539 if (ret_spec == NULL) {
5540 /* Clean up and bail */
5541 PerlMem_free(vmsdefspec);
5542 if (vmsfspec != NULL)
5543 PerlMem_free(vmsfspec);
5546 def_spec = (const char *)vmsdefspec;
5548 rms_set_dna(myfab, mynam,
5549 (char *)def_spec, strlen(def_spec)); /* cast ok */
5552 /* Now we need the expansion buffers */
5553 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5554 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5555 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5556 esal = PerlMem_malloc(VMS_MAXRSS);
5557 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5559 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5561 /* If a NAML block is used RMS always writes to the long and short
5562 * addresses unless you suppress the short name.
5564 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5565 outbufl = PerlMem_malloc(VMS_MAXRSS);
5566 if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5568 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5570 #ifdef NAM$M_NO_SHORT_UPCASE
5571 if (decc_efs_case_preserve)
5572 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5575 /* We may not want to follow symbolic links */
5576 #ifdef NAML$M_OPEN_SPECIAL
5577 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5578 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5581 /* First attempt to parse as an existing file */
5582 retsts = sys$parse(&myfab,0,0);
5583 if (!(retsts & STS$K_SUCCESS)) {
5585 /* Could not find the file, try as syntax only if error is not fatal */
5586 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5587 if (retsts == RMS$_DNF ||
5588 retsts == RMS$_DIR ||
5589 retsts == RMS$_DEV ||
5590 retsts == RMS$_PRV) {
5591 retsts = sys$parse(&myfab,0,0);
5592 if (retsts & STS$K_SUCCESS) goto int_expanded;
5595 /* Still could not parse the file specification */
5596 /*----------------------------------------------*/
5597 sts = rms_free_search_context(&myfab); /* Free search context */
5598 if (vmsdefspec != NULL)
5599 PerlMem_free(vmsdefspec);
5600 if (vmsfspec != NULL)
5601 PerlMem_free(vmsfspec);
5602 if (outbufl != NULL)
5603 PerlMem_free(outbufl);
5607 set_vaxc_errno(retsts);
5608 if (retsts == RMS$_PRV) set_errno(EACCES);
5609 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5610 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5611 else set_errno(EVMSERR);
5614 retsts = sys$search(&myfab,0,0);
5615 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5616 sts = rms_free_search_context(&myfab); /* Free search context */
5617 if (vmsdefspec != NULL)
5618 PerlMem_free(vmsdefspec);
5619 if (vmsfspec != NULL)
5620 PerlMem_free(vmsfspec);
5621 if (outbufl != NULL)
5622 PerlMem_free(outbufl);
5626 set_vaxc_errno(retsts);
5627 if (retsts == RMS$_PRV) set_errno(EACCES);
5628 else set_errno(EVMSERR);
5632 /* If the input filespec contained any lowercase characters,
5633 * downcase the result for compatibility with Unix-minded code. */
5635 if (!decc_efs_case_preserve) {
5637 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5638 if (islower(*tbuf)) { haslower = 1; break; }
5641 /* Is a long or a short name expected */
5642 /*------------------------------------*/
5644 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5645 if (rms_nam_rsll(mynam)) {
5647 speclen = rms_nam_rsll(mynam);
5650 spec_buf = esal; /* Not esa */
5651 speclen = rms_nam_esll(mynam);
5655 if (rms_nam_rsl(mynam)) {
5657 speclen = rms_nam_rsl(mynam);
5660 spec_buf = esa; /* Not esal */
5661 speclen = rms_nam_esl(mynam);
5664 spec_buf[speclen] = '\0';
5666 /* Trim off null fields added by $PARSE
5667 * If type > 1 char, must have been specified in original or default spec
5668 * (not true for version; $SEARCH may have added version of existing file).
5670 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5671 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5672 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5673 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5676 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5677 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5679 if (trimver || trimtype) {
5680 if (defspec && *defspec) {
5681 char *defesal = NULL;
5682 char *defesa = NULL;
5683 defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5684 if (defesa != NULL) {
5685 struct FAB deffab = cc$rms_fab;
5686 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5687 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5688 if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5690 rms_setup_nam(defnam);
5692 rms_bind_fab_nam(deffab, defnam);
5696 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5698 /* RMS needs the esa/esal as a work area if wildcards are involved */
5699 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5701 rms_clear_nam_nop(defnam);
5702 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5703 #ifdef NAM$M_NO_SHORT_UPCASE
5704 if (decc_efs_case_preserve)
5705 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5707 #ifdef NAML$M_OPEN_SPECIAL
5708 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5709 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5711 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5713 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5716 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5719 if (defesal != NULL)
5720 PerlMem_free(defesal);
5721 PerlMem_free(defesa);
5723 _ckvmssts_noperl(SS$_INSFMEM);
5727 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5728 if (*(rms_nam_verl(mynam)) != '\"')
5729 speclen = rms_nam_verl(mynam) - spec_buf;
5732 if (*(rms_nam_ver(mynam)) != '\"')
5733 speclen = rms_nam_ver(mynam) - spec_buf;
5737 /* If we didn't already trim version, copy down */
5738 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5739 if (speclen > rms_nam_verl(mynam) - spec_buf)
5741 (rms_nam_typel(mynam),
5742 rms_nam_verl(mynam),
5743 speclen - (rms_nam_verl(mynam) - spec_buf));
5744 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5747 if (speclen > rms_nam_ver(mynam) - spec_buf)
5749 (rms_nam_type(mynam),
5751 speclen - (rms_nam_ver(mynam) - spec_buf));
5752 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5757 /* Done with these copies of the input files */
5758 /*-------------------------------------------*/
5759 if (vmsfspec != NULL)
5760 PerlMem_free(vmsfspec);
5761 if (vmsdefspec != NULL)
5762 PerlMem_free(vmsdefspec);
5764 /* If we just had a directory spec on input, $PARSE "helpfully"
5765 * adds an empty name and type for us */
5766 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5767 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5768 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5769 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5770 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5771 speclen = rms_nam_namel(mynam) - spec_buf;
5776 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5777 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5778 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5779 speclen = rms_nam_name(mynam) - spec_buf;
5782 /* Posix format specifications must have matching quotes */
5783 if (speclen < (VMS_MAXRSS - 1)) {
5784 if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5785 if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5786 spec_buf[speclen] = '\"';
5791 spec_buf[speclen] = '\0';
5792 if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5794 /* Have we been working with an expanded, but not resultant, spec? */
5795 /* Also, convert back to Unix syntax if necessary. */
5799 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5800 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5801 rsl = rms_nam_rsll(mynam);
5805 rsl = rms_nam_rsl(mynam);
5808 /* rsl is not present, it means that spec_buf is either */
5809 /* esa or esal, and needs to be copied to outbuf */
5810 /* convert to Unix if desired */
5812 ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5814 /* VMS file specs are not in UTF-8 */
5815 if (fs_utf8 != NULL)
5817 strcpy(outbuf, spec_buf);
5822 /* Now spec_buf is either outbuf or outbufl */
5823 /* We need the result into outbuf */
5825 /* If we need this in UNIX, then we need another buffer */
5826 /* to keep things in order */
5828 char * new_src = NULL;
5829 if (spec_buf == outbuf) {
5830 new_src = PerlMem_malloc(VMS_MAXRSS);
5831 strcpy(new_src, spec_buf);
5835 ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5837 PerlMem_free(new_src);
5840 /* VMS file specs are not in UTF-8 */
5841 if (fs_utf8 != NULL)
5844 /* Copy the buffer if needed */
5845 if (outbuf != spec_buf)
5846 strcpy(outbuf, spec_buf);
5852 /* Need to clean up the search context */
5853 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5854 sts = rms_free_search_context(&myfab); /* Free search context */
5856 /* Clean up the extra buffers */
5860 if (outbufl != NULL)
5861 PerlMem_free(outbufl);
5863 /* Return the result */
5867 /* Common simple case - Expand an already VMS spec */
5869 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5870 opts |= PERL_RMSEXPAND_M_VMS_IN;
5871 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5874 /* Common simple case - Expand to a VMS spec */
5876 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5877 opts |= PERL_RMSEXPAND_M_VMS;
5878 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5882 /* Entry point used by perl routines */
5885 (pTHX_ const char *filespec,
5888 const char *defspec,
5893 static char __rmsexpand_retbuf[VMS_MAXRSS];
5894 char * expanded, *ret_spec, *ret_buf;
5898 if (ret_buf == NULL) {
5900 Newx(expanded, VMS_MAXRSS, char);
5901 if (expanded == NULL)
5902 _ckvmssts(SS$_INSFMEM);
5905 ret_buf = __rmsexpand_retbuf;
5910 ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5911 opts, fs_utf8, dfs_utf8);
5913 if (ret_spec == NULL) {
5914 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5922 /* External entry points */
5923 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5924 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5925 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5926 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5927 char *Perl_rmsexpand_utf8
5928 (pTHX_ const char *spec, char *buf, const char *def,
5929 unsigned opt, int * fs_utf8, int * dfs_utf8)
5930 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5931 char *Perl_rmsexpand_utf8_ts
5932 (pTHX_ const char *spec, char *buf, const char *def,
5933 unsigned opt, int * fs_utf8, int * dfs_utf8)
5934 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5938 ** The following routines are provided to make life easier when
5939 ** converting among VMS-style and Unix-style directory specifications.
5940 ** All will take input specifications in either VMS or Unix syntax. On
5941 ** failure, all return NULL. If successful, the routines listed below
5942 ** return a pointer to a buffer containing the appropriately
5943 ** reformatted spec (and, therefore, subsequent calls to that routine
5944 ** will clobber the result), while the routines of the same names with
5945 ** a _ts suffix appended will return a pointer to a mallocd string
5946 ** containing the appropriately reformatted spec.
5947 ** In all cases, only explicit syntax is altered; no check is made that
5948 ** the resulting string is valid or that the directory in question
5951 ** fileify_dirspec() - convert a directory spec into the name of the
5952 ** directory file (i.e. what you can stat() to see if it's a dir).
5953 ** The style (VMS or Unix) of the result is the same as the style
5954 ** of the parameter passed in.
5955 ** pathify_dirspec() - convert a directory spec into a path (i.e.
5956 ** what you prepend to a filename to indicate what directory it's in).
5957 ** The style (VMS or Unix) of the result is the same as the style
5958 ** of the parameter passed in.
5959 ** tounixpath() - convert a directory spec into a Unix-style path.
5960 ** tovmspath() - convert a directory spec into a VMS-style path.
5961 ** tounixspec() - convert any file spec into a Unix-style file spec.
5962 ** tovmsspec() - convert any file spec into a VMS-style spec.
5963 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5965 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
5966 ** Permission is given to distribute this code as part of the Perl
5967 ** standard distribution under the terms of the GNU General Public
5968 ** License or the Perl Artistic License. Copies of each may be
5969 ** found in the Perl standard distribution.
5972 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5974 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5976 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5977 char *cp1, *cp2, *lastdir;
5978 char *trndir, *vmsdir;
5979 unsigned short int trnlnm_iter_count;
5983 if (utf8_fl != NULL)
5986 if (!dir || !*dir) {
5987 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5989 dirlen = strlen(dir);
5990 while (dirlen && dir[dirlen-1] == '/') --dirlen;
5991 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5992 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5999 if (dirlen > (VMS_MAXRSS - 1)) {
6000 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6003 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6004 if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6005 if (!strpbrk(dir+1,"/]>:") &&
6006 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6007 strcpy(trndir,*dir == '/' ? dir + 1: dir);
6008 trnlnm_iter_count = 0;
6009 while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6010 trnlnm_iter_count++;
6011 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6013 dirlen = strlen(trndir);
6016 strncpy(trndir,dir,dirlen);
6017 trndir[dirlen] = '\0';
6020 /* At this point we are done with *dir and use *trndir which is a
6021 * copy that can be modified. *dir must not be modified.
6024 /* If we were handed a rooted logical name or spec, treat it like a
6025 * simple directory, so that
6026 * $ Define myroot dev:[dir.]
6027 * ... do_fileify_dirspec("myroot",buf,1) ...
6028 * does something useful.
6030 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6031 trndir[--dirlen] = '\0';
6032 trndir[dirlen-1] = ']';
6034 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6035 trndir[--dirlen] = '\0';
6036 trndir[dirlen-1] = '>';
6039 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6040 /* If we've got an explicit filename, we can just shuffle the string. */
6041 if (*(cp1+1)) hasfilename = 1;
6042 /* Similarly, we can just back up a level if we've got multiple levels
6043 of explicit directories in a VMS spec which ends with directories. */
6045 for (cp2 = cp1; cp2 > trndir; cp2--) {
6047 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6048 /* fix-me, can not scan EFS file specs backward like this */
6049 *cp2 = *cp1; *cp1 = '\0';
6054 if (*cp2 == '[' || *cp2 == '<') break;
6059 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6060 if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6061 cp1 = strpbrk(trndir,"]:>");
6062 if (hasfilename || !cp1) { /* filename present or not VMS */
6064 if (decc_efs_charset && !cp1) {
6066 /* EFS handling for UNIX mode */
6068 /* Just remove the trailing '/' and we should be done */
6070 trndir_len = strlen(trndir);
6072 if (trndir_len > 1) {
6074 if (trndir[trndir_len] == '/') {
6075 trndir[trndir_len] = '\0';
6078 strcpy(buf, trndir);
6079 PerlMem_free(trndir);
6080 PerlMem_free(vmsdir);
6084 /* For non-EFS mode, this is left for backwards compatibility */
6085 /* For EFS mode, this is only done for VMS format filespecs as */
6086 /* Perl programs generally have problems when a UNIX format spec */
6087 /* returns a VMS format spec */
6088 if (trndir[0] == '.') {
6089 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6090 PerlMem_free(trndir);
6091 PerlMem_free(vmsdir);
6092 return int_fileify_dirspec("[]", buf, NULL);
6094 else if (trndir[1] == '.' &&
6095 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6096 PerlMem_free(trndir);
6097 PerlMem_free(vmsdir);
6098 return int_fileify_dirspec("[-]", buf, NULL);
6101 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
6102 dirlen -= 1; /* to last element */
6103 lastdir = strrchr(trndir,'/');
6105 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6106 /* If we have "/." or "/..", VMSify it and let the VMS code
6107 * below expand it, rather than repeating the code to handle
6108 * relative components of a filespec here */
6110 if (*(cp1+2) == '.') cp1++;
6111 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6113 if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6114 PerlMem_free(trndir);
6115 PerlMem_free(vmsdir);
6118 if (strchr(vmsdir,'/') != NULL) {
6119 /* If int_tovmsspec() returned it, it must have VMS syntax
6120 * delimiters in it, so it's a mixed VMS/Unix spec. We take
6121 * the time to check this here only so we avoid a recursion
6122 * loop; otherwise, gigo.
6124 PerlMem_free(trndir);
6125 PerlMem_free(vmsdir);
6126 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
6129 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6130 PerlMem_free(trndir);
6131 PerlMem_free(vmsdir);
6134 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6135 PerlMem_free(trndir);
6136 PerlMem_free(vmsdir);
6140 } while ((cp1 = strstr(cp1,"/.")) != NULL);
6141 lastdir = strrchr(trndir,'/');
6143 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6145 /* Ditto for specs that end in an MFD -- let the VMS code
6146 * figure out whether it's a real device or a rooted logical. */
6148 /* This should not happen any more. Allowing the fake /000000
6149 * in a UNIX pathname causes all sorts of problems when trying
6150 * to run in UNIX emulation. So the VMS to UNIX conversions
6151 * now remove the fake /000000 directories.
6154 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6155 if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6156 PerlMem_free(trndir);
6157 PerlMem_free(vmsdir);
6160 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6161 PerlMem_free(trndir);
6162 PerlMem_free(vmsdir);
6165 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6166 PerlMem_free(trndir);
6167 PerlMem_free(vmsdir);
6172 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6173 !(lastdir = cp1 = strrchr(trndir,']')) &&
6174 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6176 cp2 = strrchr(cp1,'.');
6178 int e_len, vs_len = 0;
6181 cp3 = strchr(cp2,';');
6182 e_len = strlen(cp2);
6184 vs_len = strlen(cp3);
6185 e_len = e_len - vs_len;
6187 is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6189 if (!decc_efs_charset) {
6190 /* If this is not EFS, then not a directory */
6191 PerlMem_free(trndir);
6192 PerlMem_free(vmsdir);
6194 set_vaxc_errno(RMS$_DIR);
6198 /* Ok, here we have an issue, technically if a .dir shows */
6199 /* from inside a directory, then we should treat it as */
6200 /* xxx^.dir.dir. But we do not have that context at this */
6201 /* point unless this is totally restructured, so we remove */
6202 /* The .dir for now, and fix this better later */
6203 dirlen = cp2 - trndir;
6209 retlen = dirlen + 6;
6210 memcpy(buf, trndir, dirlen);
6213 /* We've picked up everything up to the directory file name.
6214 Now just add the type and version, and we're set. */
6216 /* We should only add type for VMS syntax, but historically Perl
6217 has added it for UNIX style also */
6219 /* Fix me - we should not be using the same routine for VMS and
6220 UNIX format files. Things are too tangled so we need to lookup
6221 what syntax the output is */
6225 lastdir = strrchr(trndir,'/');
6229 lastdir = strpbrk(trndir,"]:>");
6235 if ((is_vms == 0) && (is_unix == 0)) {
6236 /* We still do not know? */
6237 is_unix = decc_filename_unix_report;
6242 if ((is_unix && !decc_efs_charset) || is_vms) {
6244 /* It is a bug to add a .dir to a UNIX format directory spec */
6245 /* However Perl on VMS may have programs that expect this so */
6246 /* If not using EFS character specifications allow it. */
6248 if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6249 /* Traditionally Perl expects filenames in lower case */
6250 strcat(buf, ".dir");
6252 /* VMS expects the .DIR to be in upper case */
6253 strcat(buf, ".DIR");
6256 /* It is also a bug to put a VMS format version on a UNIX file */
6257 /* specification. Perl self tests are looking for this */
6258 if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6261 PerlMem_free(trndir);
6262 PerlMem_free(vmsdir);
6265 else { /* VMS-style directory spec */
6267 char *esa, *esal, term, *cp;
6270 unsigned long int sts, cmplen, haslower = 0;
6271 unsigned int nam_fnb;
6273 struct FAB dirfab = cc$rms_fab;
6274 rms_setup_nam(savnam);
6275 rms_setup_nam(dirnam);
6277 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6278 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6280 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6281 esal = PerlMem_malloc(VMS_MAXRSS);
6282 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6284 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6285 rms_bind_fab_nam(dirfab, dirnam);
6286 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6287 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6288 #ifdef NAM$M_NO_SHORT_UPCASE
6289 if (decc_efs_case_preserve)
6290 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6293 for (cp = trndir; *cp; cp++)
6294 if (islower(*cp)) { haslower = 1; break; }
6295 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6296 if ((dirfab.fab$l_sts == RMS$_DIR) ||
6297 (dirfab.fab$l_sts == RMS$_DNF) ||
6298 (dirfab.fab$l_sts == RMS$_PRV)) {
6299 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6300 sts = sys$parse(&dirfab);
6306 PerlMem_free(trndir);
6307 PerlMem_free(vmsdir);
6309 set_vaxc_errno(dirfab.fab$l_sts);
6315 /* Does the file really exist? */
6316 if (sys$search(&dirfab)& STS$K_SUCCESS) {
6317 /* Yes; fake the fnb bits so we'll check type below */
6318 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6320 else { /* No; just work with potential name */
6321 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6324 fab_sts = dirfab.fab$l_sts;
6325 sts = rms_free_search_context(&dirfab);
6329 PerlMem_free(trndir);
6330 PerlMem_free(vmsdir);
6331 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
6337 /* Make sure we are using the right buffer */
6340 my_esa_len = rms_nam_esll(dirnam);
6343 my_esa_len = rms_nam_esl(dirnam);
6345 my_esa[my_esa_len] = '\0';
6346 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6347 cp1 = strchr(my_esa,']');
6348 if (!cp1) cp1 = strchr(my_esa,'>');
6349 if (cp1) { /* Should always be true */
6350 my_esa_len -= cp1 - my_esa - 1;
6351 memmove(my_esa, cp1 + 1, my_esa_len);
6354 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6355 /* Yep; check version while we're at it, if it's there. */
6356 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6357 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6358 /* Something other than .DIR[;1]. Bzzt. */
6359 sts = rms_free_search_context(&dirfab);
6363 PerlMem_free(trndir);
6364 PerlMem_free(vmsdir);
6366 set_vaxc_errno(RMS$_DIR);
6371 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6372 /* They provided at least the name; we added the type, if necessary, */
6373 strcpy(buf, my_esa);
6374 sts = rms_free_search_context(&dirfab);
6375 PerlMem_free(trndir);
6379 PerlMem_free(vmsdir);
6382 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6383 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6387 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6388 if (cp1 == NULL) { /* should never happen */
6389 sts = rms_free_search_context(&dirfab);
6390 PerlMem_free(trndir);
6394 PerlMem_free(vmsdir);
6399 retlen = strlen(my_esa);
6400 cp1 = strrchr(my_esa,'.');
6401 /* ODS-5 directory specifications can have extra "." in them. */
6402 /* Fix-me, can not scan EFS file specifications backwards */
6403 while (cp1 != NULL) {
6404 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6408 while ((cp1 > my_esa) && (*cp1 != '.'))
6415 if ((cp1) != NULL) {
6416 /* There's more than one directory in the path. Just roll back. */
6418 strcpy(buf, my_esa);
6421 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6422 /* Go back and expand rooted logical name */
6423 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6424 #ifdef NAM$M_NO_SHORT_UPCASE
6425 if (decc_efs_case_preserve)
6426 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6428 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6429 sts = rms_free_search_context(&dirfab);
6433 PerlMem_free(trndir);
6434 PerlMem_free(vmsdir);
6436 set_vaxc_errno(dirfab.fab$l_sts);
6440 /* This changes the length of the string of course */
6442 my_esa_len = rms_nam_esll(dirnam);
6444 my_esa_len = rms_nam_esl(dirnam);
6447 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6448 cp1 = strstr(my_esa,"][");
6449 if (!cp1) cp1 = strstr(my_esa,"]<");
6450 dirlen = cp1 - my_esa;
6451 memcpy(buf, my_esa, dirlen);
6452 if (!strncmp(cp1+2,"000000]",7)) {
6453 buf[dirlen-1] = '\0';
6454 /* fix-me Not full ODS-5, just extra dots in directories for now */
6455 cp1 = buf + dirlen - 1;
6461 if (*(cp1-1) != '^')
6466 if (*cp1 == '.') *cp1 = ']';
6468 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6469 memmove(cp1+1,"000000]",7);
6473 memmove(buf+dirlen, cp1+2, retlen-dirlen);
6475 /* Convert last '.' to ']' */
6477 while (*cp != '[') {
6480 /* Do not trip on extra dots in ODS-5 directories */
6481 if ((cp1 == buf) || (*(cp1-1) != '^'))
6485 if (*cp1 == '.') *cp1 = ']';
6487 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6488 memmove(cp1+1,"000000]",7);
6492 else { /* This is a top-level dir. Add the MFD to the path. */
6495 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6496 strcpy(cp2,":[000000]");
6501 sts = rms_free_search_context(&dirfab);
6502 /* We've set up the string up through the filename. Add the
6503 type and version, and we're done. */
6504 strcat(buf,".DIR;1");
6506 /* $PARSE may have upcased filespec, so convert output to lower
6507 * case if input contained any lowercase characters. */
6508 if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6509 PerlMem_free(trndir);
6513 PerlMem_free(vmsdir);
6516 } /* end of int_fileify_dirspec() */
6519 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6520 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6522 static char __fileify_retbuf[VMS_MAXRSS];
6523 char * fileified, *ret_spec, *ret_buf;
6527 if (ret_buf == NULL) {
6529 Newx(fileified, VMS_MAXRSS, char);
6530 if (fileified == NULL)
6531 _ckvmssts(SS$_INSFMEM);
6532 ret_buf = fileified;
6534 ret_buf = __fileify_retbuf;
6538 ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6540 if (ret_spec == NULL) {
6541 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6543 Safefree(fileified);
6547 } /* end of do_fileify_dirspec() */
6550 /* External entry points */
6551 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6552 { return do_fileify_dirspec(dir,buf,0,NULL); }
6553 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6554 { return do_fileify_dirspec(dir,buf,1,NULL); }
6555 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6556 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6557 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6558 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6560 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6561 char * v_spec, int v_len, char * r_spec, int r_len,
6562 char * d_spec, int d_len, char * n_spec, int n_len,
6563 char * e_spec, int e_len, char * vs_spec, int vs_len) {
6565 /* VMS specification - Try to do this the simple way */
6566 if ((v_len + r_len > 0) || (d_len > 0)) {
6569 /* No name or extension component, already a directory */
6570 if ((n_len + e_len + vs_len) == 0) {
6575 /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6576 /* This results from catfile() being used instead of catdir() */
6577 /* So even though it should not work, we need to allow it */
6579 /* If this is .DIR;1 then do a simple conversion */
6580 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6581 if (is_dir || (e_len == 0) && (d_len > 0)) {
6583 len = v_len + r_len + d_len - 1;
6584 char dclose = d_spec[d_len - 1];
6585 strncpy(buf, dir, len);
6588 strncpy(&buf[len], n_spec, n_len);
6591 buf[len + 1] = '\0';
6596 else if (d_len > 0) {
6597 /* In the olden days, a directory needed to have a .DIR */
6598 /* extension to be a valid directory, but now it could */
6599 /* be a symbolic link */
6601 len = v_len + r_len + d_len - 1;
6602 char dclose = d_spec[d_len - 1];
6603 strncpy(buf, dir, len);
6606 strncpy(&buf[len], n_spec, n_len);
6609 if (decc_efs_charset) {
6612 strncpy(&buf[len], e_spec, e_len);
6615 set_vaxc_errno(RMS$_DIR);
6621 buf[len + 1] = '\0';
6626 set_vaxc_errno(RMS$_DIR);
6632 set_vaxc_errno(RMS$_DIR);
6638 /* Internal routine to make sure or convert a directory to be in a */
6639 /* path specification. No utf8 flag because it is not changed or used */
6640 static char *int_pathify_dirspec(const char *dir, char *buf)
6642 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6643 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6644 char * exp_spec, *ret_spec;
6646 unsigned short int trnlnm_iter_count;
6650 if (vms_debug_fileify) {
6652 fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6654 fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6657 /* We may need to lower case the result if we translated */
6658 /* a logical name or got the current working directory */
6661 if (!dir || !*dir) {
6663 set_vaxc_errno(SS$_BADPARAM);
6667 trndir = PerlMem_malloc(VMS_MAXRSS);
6669 _ckvmssts_noperl(SS$_INSFMEM);
6671 /* If no directory specified use the current default */
6673 strcpy(trndir, dir);
6675 getcwd(trndir, VMS_MAXRSS - 1);
6679 /* now deal with bare names that could be logical names */
6680 trnlnm_iter_count = 0;
6681 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6682 && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6683 trnlnm_iter_count++;
6685 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6687 trnlen = strlen(trndir);
6689 /* Trap simple rooted lnms, and return lnm:[000000] */
6690 if (!strcmp(trndir+trnlen-2,".]")) {
6692 strcat(buf, ":[000000]");
6693 PerlMem_free(trndir);
6695 if (vms_debug_fileify) {
6696 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6702 /* At this point we do not work with *dir, but the copy in *trndir */
6704 if (need_to_lower && !decc_efs_case_preserve) {
6705 /* Legacy mode, lower case the returned value */
6706 __mystrtolower(trndir);
6710 /* Some special cases, '..', '.' */
6712 if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6713 /* Force UNIX filespec */
6717 /* Is this Unix or VMS format? */
6718 sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6719 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6720 &e_len, &vs_spec, &vs_len);
6723 /* Just a filename? */
6724 if ((v_len + r_len + d_len) == 0) {
6726 /* Now we have a problem, this could be Unix or VMS */
6727 /* We have to guess. .DIR usually means VMS */
6729 /* In UNIX report mode, the .DIR extension is removed */
6730 /* if one shows up, it is for a non-directory or a directory */
6731 /* in EFS charset mode */
6733 /* So if we are in Unix report mode, assume that this */
6734 /* is a relative Unix directory specification */
6737 if (!decc_filename_unix_report && decc_efs_charset) {
6739 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6742 /* Traditional mode, assume .DIR is directory */
6745 strncpy(&buf[2], n_spec, n_len);
6746 buf[n_len + 2] = ']';
6747 buf[n_len + 3] = '\0';
6748 PerlMem_free(trndir);
6749 if (vms_debug_fileify) {
6751 "int_pathify_dirspec: buf = %s\n",
6761 ret_spec = int_pathify_dirspec_simple(trndir, buf,
6762 v_spec, v_len, r_spec, r_len,
6763 d_spec, d_len, n_spec, n_len,
6764 e_spec, e_len, vs_spec, vs_len);
6766 if (ret_spec != NULL) {
6767 PerlMem_free(trndir);
6768 if (vms_debug_fileify) {
6770 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6775 /* Simple way did not work, which means that a logical name */
6776 /* was present for the directory specification. */
6777 /* Need to use an rmsexpand variant to decode it completely */
6778 exp_spec = PerlMem_malloc(VMS_MAXRSS);
6779 if (exp_spec == NULL)
6780 _ckvmssts_noperl(SS$_INSFMEM);
6782 ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6783 if (ret_spec != NULL) {
6784 sts = vms_split_path(exp_spec, &v_spec, &v_len,
6785 &r_spec, &r_len, &d_spec, &d_len,
6786 &n_spec, &n_len, &e_spec,
6787 &e_len, &vs_spec, &vs_len);
6789 ret_spec = int_pathify_dirspec_simple(
6790 exp_spec, buf, v_spec, v_len, r_spec, r_len,
6791 d_spec, d_len, n_spec, n_len,
6792 e_spec, e_len, vs_spec, vs_len);
6794 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6795 /* Legacy mode, lower case the returned value */
6796 __mystrtolower(ret_spec);
6799 set_vaxc_errno(RMS$_DIR);
6804 PerlMem_free(exp_spec);
6805 PerlMem_free(trndir);
6806 if (vms_debug_fileify) {
6807 if (ret_spec == NULL)
6808 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6811 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6816 /* Unix specification, Could be trivial conversion */
6818 dir_len = strlen(trndir);
6820 /* If the extended file character set is in effect */
6821 /* then pathify is simple */
6823 if (!decc_efs_charset) {
6824 /* Have to deal with traiing '.dir' or extra '.' */
6825 /* that should not be there in legacy mode, but is */
6831 lastslash = strrchr(trndir, '/');
6832 if (lastslash == NULL)
6839 /* '..' or '.' are valid directory components */
6841 if (lastslash[0] == '.') {
6842 if (lastslash[1] == '\0') {
6844 } else if (lastslash[1] == '.') {
6845 if (lastslash[2] == '\0') {
6848 /* And finally allow '...' */
6849 if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6857 lastdot = strrchr(lastslash, '.');
6859 if (lastdot != NULL) {
6862 /* '.dir' is discarded, and any other '.' is invalid */
6863 e_len = strlen(lastdot);
6865 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6868 dir_len = dir_len - 4;
6874 strcpy(buf, trndir);
6875 if (buf[dir_len - 1] != '/') {
6877 buf[dir_len + 1] = '\0';
6880 /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6881 if (!decc_efs_charset) {
6884 if (str[0] == '.') {
6887 while ((dots[cnt] == '.') && (cnt < 3))
6890 if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6896 for (; *str; ++str) {
6897 while (*str == '/') {
6903 /* Have to skip up to three dots which could be */
6904 /* directories, 3 dots being a VMS extension for Perl */
6907 while ((dots[cnt] == '.') && (cnt < 3)) {
6910 if (dots[cnt] == '\0')
6912 if ((cnt > 1) && (dots[cnt] != '/')) {
6918 /* too many dots? */
6919 if ((cnt == 0) || (cnt > 3)) {
6923 if (!dir_start && (*str == '.')) {
6928 PerlMem_free(trndir);
6930 if (vms_debug_fileify) {
6931 if (ret_spec == NULL)
6932 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6935 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6941 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6942 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6944 static char __pathify_retbuf[VMS_MAXRSS];
6945 char * pathified, *ret_spec, *ret_buf;
6949 if (ret_buf == NULL) {
6951 Newx(pathified, VMS_MAXRSS, char);
6952 if (pathified == NULL)
6953 _ckvmssts(SS$_INSFMEM);
6954 ret_buf = pathified;
6956 ret_buf = __pathify_retbuf;
6960 ret_spec = int_pathify_dirspec(dir, ret_buf);
6962 if (ret_spec == NULL) {
6963 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6965 Safefree(pathified);
6970 } /* end of do_pathify_dirspec() */
6973 /* External entry points */
6974 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6975 { return do_pathify_dirspec(dir,buf,0,NULL); }
6976 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6977 { return do_pathify_dirspec(dir,buf,1,NULL); }
6978 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6979 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6980 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6981 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6983 /* Internal tounixspec routine that does not use a thread context */
6984 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6985 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6987 char *dirend, *cp1, *cp3, *tmp;
6989 int devlen, dirlen, retlen = VMS_MAXRSS;
6990 int expand = 1; /* guarantee room for leading and trailing slashes */
6991 unsigned short int trnlnm_iter_count;
6993 if (utf8_fl != NULL)
6996 if (vms_debug_fileify) {
6998 fprintf(stderr, "int_tounixspec: spec = NULL\n");
7000 fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7006 set_vaxc_errno(SS$_BADPARAM);
7009 if (strlen(spec) > (VMS_MAXRSS-1)) {
7011 set_vaxc_errno(SS$_BUFFEROVF);
7015 /* New VMS specific format needs translation
7016 * glob passes filenames with trailing '\n' and expects this preserved.
7018 if (decc_posix_compliant_pathnames) {
7019 if (strncmp(spec, "\"^UP^", 5) == 0) {
7025 tunix = PerlMem_malloc(VMS_MAXRSS);
7026 if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7027 strcpy(tunix, spec);
7028 tunix_len = strlen(tunix);
7030 if (tunix[tunix_len - 1] == '\n') {
7031 tunix[tunix_len - 1] = '\"';
7032 tunix[tunix_len] = '\0';
7036 uspec = decc$translate_vms(tunix);
7037 PerlMem_free(tunix);
7038 if ((int)uspec > 0) {
7044 /* If we can not translate it, makemaker wants as-is */
7052 cmp_rslt = 0; /* Presume VMS */
7053 cp1 = strchr(spec, '/');
7057 /* Look for EFS ^/ */
7058 if (decc_efs_charset) {
7059 while (cp1 != NULL) {
7062 /* Found illegal VMS, assume UNIX */
7067 cp1 = strchr(cp1, '/');
7071 /* Look for "." and ".." */
7072 if (decc_filename_unix_report) {
7073 if (spec[0] == '.') {
7074 if ((spec[1] == '\0') || (spec[1] == '\n')) {
7078 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7084 /* This is already UNIX or at least nothing VMS understands */
7087 if (vms_debug_fileify) {
7088 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7095 dirend = strrchr(spec,']');
7096 if (dirend == NULL) dirend = strrchr(spec,'>');
7097 if (dirend == NULL) dirend = strchr(spec,':');
7098 if (dirend == NULL) {
7100 if (vms_debug_fileify) {
7101 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7106 /* Special case 1 - sys$posix_root = / */
7107 #if __CRTL_VER >= 70000000
7108 if (!decc_disable_posix_root) {
7109 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7117 /* Special case 2 - Convert NLA0: to /dev/null */
7118 #if __CRTL_VER < 70000000
7119 cmp_rslt = strncmp(spec,"NLA0:", 5);
7121 cmp_rslt = strncmp(spec,"nla0:", 5);
7123 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7125 if (cmp_rslt == 0) {
7126 strcpy(rslt, "/dev/null");
7129 if (spec[6] != '\0') {
7136 /* Also handle special case "SYS$SCRATCH:" */
7137 #if __CRTL_VER < 70000000
7138 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7140 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7142 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7144 tmp = PerlMem_malloc(VMS_MAXRSS);
7145 if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7146 if (cmp_rslt == 0) {
7149 islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7151 strcpy(rslt, "/tmp");
7154 if (spec[12] != '\0') {
7162 if (*cp2 != '[' && *cp2 != '<') {
7165 else { /* the VMS spec begins with directories */
7167 if (*cp2 == ']' || *cp2 == '>') {
7168 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7172 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7173 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7175 if (vms_debug_fileify) {
7176 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7180 trnlnm_iter_count = 0;
7183 while (*cp3 != ':' && *cp3) cp3++;
7185 if (strchr(cp3,']') != NULL) break;
7186 trnlnm_iter_count++;
7187 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7188 } while (vmstrnenv(tmp,tmp,0,fildev,0));
7193 *(cp1++) = *(cp3++);
7194 if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7196 set_errno(ENAMETOOLONG);
7197 set_vaxc_errno(SS$_BUFFEROVF);
7198 if (vms_debug_fileify) {
7199 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7201 return NULL; /* No room */
7206 if ((*cp2 == '^')) {
7207 /* EFS file escape, pass the next character as is */
7208 /* Fix me: HEX encoding for Unicode not implemented */
7211 else if ( *cp2 == '.') {
7212 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7213 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7220 for (; cp2 <= dirend; cp2++) {
7221 if ((*cp2 == '^')) {
7222 /* EFS file escape, pass the next character as is */
7223 /* Fix me: HEX encoding for Unicode not implemented */
7224 *(cp1++) = *(++cp2);
7225 /* An escaped dot stays as is -- don't convert to slash */
7226 if (*cp2 == '.') cp2++;
7230 if (*(cp2+1) == '[') cp2++;
7232 else if (*cp2 == ']' || *cp2 == '>') {
7233 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7235 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7237 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7238 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7239 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7240 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7241 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7243 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7244 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7248 else if (*cp2 == '-') {
7249 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7250 while (*cp2 == '-') {
7252 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7254 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7255 /* filespecs like */
7256 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
7257 if (vms_debug_fileify) {
7258 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7263 else *(cp1++) = *cp2;
7265 else *(cp1++) = *cp2;
7267 /* Translate the rest of the filename. */
7272 /* Fixme - for compatibility with the CRTL we should be removing */
7273 /* spaces from the file specifications, but this may show that */
7274 /* some tests that were appearing to pass are not really passing */
7280 /* Fix me hex expansions not implemented */
7281 cp2++; /* '^.' --> '.' and other. */
7287 *(cp1++) = *(cp2++);
7292 if (decc_filename_unix_no_version) {
7293 /* Easy, drop the version */
7298 /* Punt - passing the version as a dot will probably */
7299 /* break perl in weird ways, but so did passing */
7300 /* through the ; as a version. Follow the CRTL and */
7301 /* hope for the best. */
7308 /* We will need to fix this properly later */
7309 /* As Perl may be installed on an ODS-5 volume, but not */
7310 /* have the EFS_CHARSET enabled, it still may encounter */
7311 /* filenames with extra dots in them, and a precedent got */
7312 /* set which allowed them to work, that we will uphold here */
7313 /* If extra dots are present in a name and no ^ is on them */
7314 /* VMS assumes that the first one is the extension delimiter */
7315 /* the rest have an implied ^. */
7317 /* this is also a conflict as the . is also a version */
7318 /* delimiter in VMS, */
7320 *(cp1++) = *(cp2++);
7324 /* This is an extension */
7325 if (decc_readdir_dropdotnotype) {
7327 if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7328 /* Drop the dot for the extension */
7336 *(cp1++) = *(cp2++);
7341 /* This still leaves /000000/ when working with a
7342 * VMS device root or concealed root.
7348 ulen = strlen(rslt);
7350 /* Get rid of "000000/ in rooted filespecs */
7352 zeros = strstr(rslt, "/000000/");
7353 if (zeros != NULL) {
7355 mlen = ulen - (zeros - rslt) - 7;
7356 memmove(zeros, &zeros[7], mlen);
7363 if (vms_debug_fileify) {
7364 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7368 } /* end of int_tounixspec() */
7371 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7372 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7374 static char __tounixspec_retbuf[VMS_MAXRSS];
7375 char * unixspec, *ret_spec, *ret_buf;
7379 if (ret_buf == NULL) {
7381 Newx(unixspec, VMS_MAXRSS, char);
7382 if (unixspec == NULL)
7383 _ckvmssts(SS$_INSFMEM);
7386 ret_buf = __tounixspec_retbuf;
7390 ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7392 if (ret_spec == NULL) {
7393 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7400 } /* end of do_tounixspec() */
7402 /* External entry points */
7403 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7404 { return do_tounixspec(spec,buf,0, NULL); }
7405 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7406 { return do_tounixspec(spec,buf,1, NULL); }
7407 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7408 { return do_tounixspec(spec,buf,0, utf8_fl); }
7409 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7410 { return do_tounixspec(spec,buf,1, utf8_fl); }
7412 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7415 This procedure is used to identify if a path is based in either
7416 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7417 it returns the OpenVMS format directory for it.
7419 It is expecting specifications of only '/' or '/xxxx/'
7421 If a posix root does not exist, or 'xxxx' is not a directory
7422 in the posix root, it returns a failure.
7424 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7426 It is used only internally by posix_to_vmsspec_hardway().
7429 static int posix_root_to_vms
7430 (char *vmspath, int vmspath_len,
7431 const char *unixpath,
7432 const int * utf8_fl)
7435 struct FAB myfab = cc$rms_fab;
7436 rms_setup_nam(mynam);
7437 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7438 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7439 char * esa, * esal, * rsa, * rsal;
7446 unixlen = strlen(unixpath);
7451 #if __CRTL_VER >= 80200000
7452 /* If not a posix spec already, convert it */
7453 if (decc_posix_compliant_pathnames) {
7454 if (strncmp(unixpath,"\"^UP^",5) != 0) {
7455 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7458 /* This is already a VMS specification, no conversion */
7460 strncpy(vmspath,unixpath, vmspath_len);
7469 /* Check to see if this is under the POSIX root */
7470 if (decc_disable_posix_root) {
7474 /* Skip leading / */
7475 if (unixpath[0] == '/') {
7481 strcpy(vmspath,"SYS$POSIX_ROOT:");
7483 /* If this is only the / , or blank, then... */
7484 if (unixpath[0] == '\0') {
7485 /* by definition, this is the answer */
7489 /* Need to look up a directory */
7493 /* Copy and add '^' escape characters as needed */
7496 while (unixpath[i] != 0) {
7499 j += copy_expand_unix_filename_escape
7500 (&vmspath[j], &unixpath[i], &k, utf8_fl);
7504 path_len = strlen(vmspath);
7505 if (vmspath[path_len - 1] == '/')
7507 vmspath[path_len] = ']';
7509 vmspath[path_len] = '\0';
7512 vmspath[vmspath_len] = 0;
7513 if (unixpath[unixlen - 1] == '/')
7515 esal = PerlMem_malloc(VMS_MAXRSS);
7516 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7517 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7518 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7519 rsal = PerlMem_malloc(VMS_MAXRSS);
7520 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7521 rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7522 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7523 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7524 rms_bind_fab_nam(myfab, mynam);
7525 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7526 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7527 if (decc_efs_case_preserve)
7528 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7529 #ifdef NAML$M_OPEN_SPECIAL
7530 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7533 /* Set up the remaining naml fields */
7534 sts = sys$parse(&myfab);
7536 /* It failed! Try again as a UNIX filespec */
7545 /* get the Device ID and the FID */
7546 sts = sys$search(&myfab);
7548 /* These are no longer needed */
7553 /* on any failure, returned the POSIX ^UP^ filespec */
7558 specdsc.dsc$a_pointer = vmspath;
7559 specdsc.dsc$w_length = vmspath_len;
7561 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7562 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7563 sts = lib$fid_to_name
7564 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7566 /* on any failure, returned the POSIX ^UP^ filespec */
7568 /* This can happen if user does not have permission to read directories */
7569 if (strncmp(unixpath,"\"^UP^",5) != 0)
7570 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7572 strcpy(vmspath, unixpath);
7575 vmspath[specdsc.dsc$w_length] = 0;
7577 /* Are we expecting a directory? */
7578 if (dir_flag != 0) {
7584 i = specdsc.dsc$w_length - 1;
7588 /* Version must be '1' */
7589 if (vmspath[i--] != '1')
7591 /* Version delimiter is one of ".;" */
7592 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7595 if (vmspath[i--] != 'R')
7597 if (vmspath[i--] != 'I')
7599 if (vmspath[i--] != 'D')
7601 if (vmspath[i--] != '.')
7603 eptr = &vmspath[i+1];
7605 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7606 if (vmspath[i-1] != '^') {
7614 /* Get rid of 6 imaginary zero directory filename */
7615 vmspath[i+1] = '\0';
7619 if (vmspath[i] == '0')
7633 /* /dev/mumble needs to be handled special.
7634 /dev/null becomes NLA0:, And there is the potential for other stuff
7635 like /dev/tty which may need to be mapped to something.
7639 slash_dev_special_to_vms
7640 (const char * unixptr,
7650 nextslash = strchr(unixptr, '/');
7651 len = strlen(unixptr);
7652 if (nextslash != NULL)
7653 len = nextslash - unixptr;
7654 cmp = strncmp("null", unixptr, 5);
7656 if (vmspath_len >= 6) {
7657 strcpy(vmspath, "_NLA0:");
7664 /* The built in routines do not understand perl's special needs, so
7665 doing a manual conversion from UNIX to VMS
7667 If the utf8_fl is not null and points to a non-zero value, then
7668 treat 8 bit characters as UTF-8.
7670 The sequence starting with '$(' and ending with ')' will be passed
7671 through with out interpretation instead of being escaped.
7674 static int posix_to_vmsspec_hardway
7675 (char *vmspath, int vmspath_len,
7676 const char *unixpath,
7681 const char *unixptr;
7682 const char *unixend;
7684 const char *lastslash;
7685 const char *lastdot;
7691 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7692 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7694 if (utf8_fl != NULL)
7700 /* Ignore leading "/" characters */
7701 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7704 unixlen = strlen(unixptr);
7706 /* Do nothing with blank paths */
7713 /* This could have a "^UP^ on the front */
7714 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7720 lastslash = strrchr(unixptr,'/');
7721 lastdot = strrchr(unixptr,'.');
7722 unixend = strrchr(unixptr,'\"');
7723 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7724 unixend = unixptr + unixlen;
7727 /* last dot is last dot or past end of string */
7728 if (lastdot == NULL)
7729 lastdot = unixptr + unixlen;
7731 /* if no directories, set last slash to beginning of string */
7732 if (lastslash == NULL) {
7733 lastslash = unixptr;
7736 /* Watch out for trailing "." after last slash, still a directory */
7737 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7738 lastslash = unixptr + unixlen;
7741 /* Watch out for traiing ".." after last slash, still a directory */
7742 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7743 lastslash = unixptr + unixlen;
7746 /* dots in directories are aways escaped */
7747 if (lastdot < lastslash)
7748 lastdot = unixptr + unixlen;
7751 /* if (unixptr < lastslash) then we are in a directory */
7758 /* Start with the UNIX path */
7759 if (*unixptr != '/') {
7760 /* relative paths */
7762 /* If allowing logical names on relative pathnames, then handle here */
7763 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7764 !decc_posix_compliant_pathnames) {
7770 /* Find the next slash */
7771 nextslash = strchr(unixptr,'/');
7773 esa = PerlMem_malloc(vmspath_len);
7774 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7776 trn = PerlMem_malloc(VMS_MAXRSS);
7777 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7779 if (nextslash != NULL) {
7781 seg_len = nextslash - unixptr;
7782 strncpy(esa, unixptr, seg_len);
7786 strcpy(esa, unixptr);
7787 seg_len = strlen(unixptr);
7789 /* trnlnm(section) */
7790 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7793 /* Now fix up the directory */
7795 /* Split up the path to find the components */
7796 sts = vms_split_path
7815 /* A logical name must be a directory or the full
7816 specification. It is only a full specification if
7817 it is the only component */
7818 if ((unixptr[seg_len] == '\0') ||
7819 (unixptr[seg_len+1] == '\0')) {
7821 /* Is a directory being required? */
7822 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7823 /* Not a logical name */
7828 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7829 /* This must be a directory */
7830 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7831 strcpy(vmsptr, esa);
7832 vmslen=strlen(vmsptr);
7833 vmsptr[vmslen] = ':';
7835 vmsptr[vmslen] = '\0';
7843 /* must be dev/directory - ignore version */
7844 if ((n_len + e_len) != 0)
7847 /* transfer the volume */
7848 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7849 strncpy(vmsptr, v_spec, v_len);
7855 /* unroot the rooted directory */
7856 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7858 r_spec[r_len - 1] = ']';
7860 /* This should not be there, but nothing is perfect */
7862 cmp = strcmp(&r_spec[1], "000000.");
7872 strncpy(vmsptr, r_spec, r_len);
7878 /* Bring over the directory. */
7880 ((d_len + vmslen) < vmspath_len)) {
7882 d_spec[d_len - 1] = ']';
7884 cmp = strcmp(&d_spec[1], "000000.");
7895 /* Remove the redundant root */
7903 strncpy(vmsptr, d_spec, d_len);
7917 if (lastslash > unixptr) {
7920 /* skip leading ./ */
7922 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7928 /* Are we still in a directory? */
7929 if (unixptr <= lastslash) {
7934 /* if not backing up, then it is relative forward. */
7935 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7936 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7944 /* Perl wants an empty directory here to tell the difference
7945 * between a DCL commmand and a filename
7954 /* Handle two special files . and .. */
7955 if (unixptr[0] == '.') {
7956 if (&unixptr[1] == unixend) {
7963 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7974 else { /* Absolute PATH handling */
7978 /* Need to find out where root is */
7980 /* In theory, this procedure should never get an absolute POSIX pathname
7981 * that can not be found on the POSIX root.
7982 * In practice, that can not be relied on, and things will show up
7983 * here that are a VMS device name or concealed logical name instead.
7984 * So to make things work, this procedure must be tolerant.
7986 esa = PerlMem_malloc(vmspath_len);
7987 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7990 nextslash = strchr(&unixptr[1],'/');
7992 if (nextslash != NULL) {
7994 seg_len = nextslash - &unixptr[1];
7995 strncpy(vmspath, unixptr, seg_len + 1);
7996 vmspath[seg_len+1] = 0;
7999 cmp = strncmp(vmspath, "dev", 4);
8001 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8002 if (sts = SS$_NORMAL)
8006 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8009 if ($VMS_STATUS_SUCCESS(sts)) {
8010 /* This is verified to be a real path */
8012 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8013 if ($VMS_STATUS_SUCCESS(sts)) {
8014 strcpy(vmspath, esa);
8015 vmslen = strlen(vmspath);
8016 vmsptr = vmspath + vmslen;
8018 if (unixptr < lastslash) {
8027 cmp = strcmp(rptr,"000000.");
8032 } /* removing 6 zeros */
8033 } /* vmslen < 7, no 6 zeros possible */
8034 } /* Not in a directory */
8035 } /* Posix root found */
8037 /* No posix root, fall back to default directory */
8038 strcpy(vmspath, "SYS$DISK:[");
8039 vmsptr = &vmspath[10];
8041 if (unixptr > lastslash) {
8050 } /* end of verified real path handling */
8055 /* Ok, we have a device or a concealed root that is not in POSIX
8056 * or we have garbage. Make the best of it.
8059 /* Posix to VMS destroyed this, so copy it again */
8060 strncpy(vmspath, &unixptr[1], seg_len);
8061 vmspath[seg_len] = 0;
8063 vmsptr = &vmsptr[vmslen];
8066 /* Now do we need to add the fake 6 zero directory to it? */
8068 if ((*lastslash == '/') && (nextslash < lastslash)) {
8069 /* No there is another directory */
8076 /* now we have foo:bar or foo:[000000]bar to decide from */
8077 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8079 if (!islnm && !decc_posix_compliant_pathnames) {
8081 cmp = strncmp("bin", vmspath, 4);
8083 /* bin => SYS$SYSTEM: */
8084 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8087 /* tmp => SYS$SCRATCH: */
8088 cmp = strncmp("tmp", vmspath, 4);
8090 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8095 trnend = islnm ? islnm - 1 : 0;
8097 /* if this was a logical name, ']' or '>' must be present */
8098 /* if not a logical name, then assume a device and hope. */
8099 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8101 /* if log name and trailing '.' then rooted - treat as device */
8102 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8104 /* Fix me, if not a logical name, a device lookup should be
8105 * done to see if the device is file structured. If the device
8106 * is not file structured, the 6 zeros should not be put on.
8108 * As it is, perl is occasionally looking for dev:[000000]tty.
8109 * which looks a little strange.
8111 * Not that easy to detect as "/dev" may be file structured with
8112 * special device files.
8115 if ((add_6zero == 0) && (*nextslash == '/') &&
8116 (&nextslash[1] == unixend)) {
8117 /* No real directory present */
8122 /* Put the device delimiter on */
8125 unixptr = nextslash;
8128 /* Start directory if needed */
8129 if (!islnm || add_6zero) {
8135 /* add fake 000000] if needed */
8148 } /* non-POSIX translation */
8150 } /* End of relative/absolute path handling */
8152 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8159 if (dir_start != 0) {
8161 /* First characters in a directory are handled special */
8162 while ((*unixptr == '/') ||
8163 ((*unixptr == '.') &&
8164 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8165 (&unixptr[1]==unixend)))) {
8170 /* Skip redundant / in specification */
8171 while ((*unixptr == '/') && (dir_start != 0)) {
8174 if (unixptr == lastslash)
8177 if (unixptr == lastslash)
8180 /* Skip redundant ./ characters */
8181 while ((*unixptr == '.') &&
8182 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8185 if (unixptr == lastslash)
8187 if (*unixptr == '/')
8190 if (unixptr == lastslash)
8193 /* Skip redundant ../ characters */
8194 while ((*unixptr == '.') && (unixptr[1] == '.') &&
8195 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8196 /* Set the backing up flag */
8202 unixptr++; /* first . */
8203 unixptr++; /* second . */
8204 if (unixptr == lastslash)
8206 if (*unixptr == '/') /* The slash */
8209 if (unixptr == lastslash)
8212 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8213 /* Not needed when VMS is pretending to be UNIX. */
8215 /* Is this loop stuck because of too many dots? */
8216 if (loop_flag == 0) {
8217 /* Exit the loop and pass the rest through */
8222 /* Are we done with directories yet? */
8223 if (unixptr >= lastslash) {
8225 /* Watch out for trailing dots */
8234 if (*unixptr == '/')
8238 /* Have we stopped backing up? */
8243 /* dir_start continues to be = 1 */
8245 if (*unixptr == '-') {
8247 *vmsptr++ = *unixptr++;
8251 /* Now are we done with directories yet? */
8252 if (unixptr >= lastslash) {
8254 /* Watch out for trailing dots */
8270 if (unixptr >= unixend)
8273 /* Normal characters - More EFS work probably needed */
8279 /* remove multiple / */
8280 while (unixptr[1] == '/') {
8283 if (unixptr == lastslash) {
8284 /* Watch out for trailing dots */
8296 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8297 /* Not needed when VMS is pretending to be UNIX. */
8301 if (unixptr != unixend)
8306 if ((unixptr < lastdot) || (unixptr < lastslash) ||
8307 (&unixptr[1] == unixend)) {
8313 /* trailing dot ==> '^..' on VMS */
8314 if (unixptr == unixend) {
8322 *vmsptr++ = *unixptr++;
8326 if (quoted && (&unixptr[1] == unixend)) {
8330 in_cnt = copy_expand_unix_filename_escape
8331 (vmsptr, unixptr, &out_cnt, utf8_fl);
8341 in_cnt = copy_expand_unix_filename_escape
8342 (vmsptr, unixptr, &out_cnt, utf8_fl);
8349 /* Make sure directory is closed */
8350 if (unixptr == lastslash) {
8352 vmsptr2 = vmsptr - 1;
8354 if (*vmsptr2 != ']') {
8357 /* directories do not end in a dot bracket */
8358 if (*vmsptr2 == '.') {
8362 if (*vmsptr2 != '^') {
8363 vmsptr--; /* back up over the dot */
8371 /* Add a trailing dot if a file with no extension */
8372 vmsptr2 = vmsptr - 1;
8374 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8375 (*vmsptr2 != ')') && (*lastdot != '.')) {
8386 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8387 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8392 /* If a UTF8 flag is being passed, honor it */
8394 if (utf8_fl != NULL) {
8395 utf8_flag = *utf8_fl;
8400 /* If there is a possibility of UTF8, then if any UTF8 characters
8401 are present, then they must be converted to VTF-7
8403 result = strcpy(rslt, path); /* FIX-ME */
8406 result = strcpy(rslt, path);
8413 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8414 static char *int_tovmsspec
8415 (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8421 unsigned long int infront = 0, hasdir = 1;
8424 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8425 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8427 if (vms_debug_fileify) {
8429 fprintf(stderr, "int_tovmsspec: path = NULL\n");
8431 fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8435 /* If we fail, we should be setting errno */
8437 set_vaxc_errno(SS$_BADPARAM);
8440 rslt_len = VMS_MAXRSS-1;
8442 /* '.' and '..' are "[]" and "[-]" for a quick check */
8443 if (path[0] == '.') {
8444 if (path[1] == '\0') {
8446 if (utf8_flag != NULL)
8451 if (path[1] == '.' && path[2] == '\0') {
8453 if (utf8_flag != NULL)
8460 /* Posix specifications are now a native VMS format */
8461 /*--------------------------------------------------*/
8462 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8463 if (decc_posix_compliant_pathnames) {
8464 if (strncmp(path,"\"^UP^",5) == 0) {
8465 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8471 /* This is really the only way to see if this is already in VMS format */
8472 sts = vms_split_path
8487 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8488 replacement, because the above parse just took care of most of
8489 what is needed to do vmspath when the specification is already
8492 And if it is not already, it is easier to do the conversion as
8493 part of this routine than to call this routine and then work on
8497 /* If VMS punctuation was found, it is already VMS format */
8498 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8499 if (utf8_flag != NULL)
8502 if (vms_debug_fileify) {
8503 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8507 /* Now, what to do with trailing "." cases where there is no
8508 extension? If this is a UNIX specification, and EFS characters
8509 are enabled, then the trailing "." should be converted to a "^.".
8510 But if this was already a VMS specification, then it should be
8513 So in the case of ambiguity, leave the specification alone.
8517 /* If there is a possibility of UTF8, then if any UTF8 characters
8518 are present, then they must be converted to VTF-7
8520 if (utf8_flag != NULL)
8523 if (vms_debug_fileify) {
8524 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8529 dirend = strrchr(path,'/');
8531 if (dirend == NULL) {
8535 /* If we get here with no UNIX directory delimiters, then this is
8536 not a complete file specification, either garbage a UNIX glob
8537 specification that can not be converted to a VMS wildcard, or
8538 it a UNIX shell macro. MakeMaker wants shell macros passed
8541 utf8 flag setting needs to be preserved.
8546 macro_start = strchr(path,'$');
8547 if (macro_start != NULL) {
8548 if (macro_start[1] == '(') {
8552 if ((decc_efs_charset == 0) || (has_macro)) {
8554 if (vms_debug_fileify) {
8555 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8561 /* If POSIX mode active, handle the conversion */
8562 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8563 if (decc_efs_charset) {
8564 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8565 if (vms_debug_fileify) {
8566 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8572 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
8573 if (!*(dirend+2)) dirend +=2;
8574 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8575 if (decc_efs_charset == 0) {
8576 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8582 lastdot = strrchr(cp2,'.');
8588 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8590 if (decc_disable_posix_root) {
8591 strcpy(rslt,"sys$disk:[000000]");
8594 strcpy(rslt,"sys$posix_root:[000000]");
8596 if (utf8_flag != NULL)
8598 if (vms_debug_fileify) {
8599 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8603 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8605 trndev = PerlMem_malloc(VMS_MAXRSS);
8606 if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8607 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8609 /* DECC special handling */
8611 if (strcmp(rslt,"bin") == 0) {
8612 strcpy(rslt,"sys$system");
8615 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8617 else if (strcmp(rslt,"tmp") == 0) {
8618 strcpy(rslt,"sys$scratch");
8621 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8623 else if (!decc_disable_posix_root) {
8624 strcpy(rslt, "sys$posix_root");
8628 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8629 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8631 else if (strcmp(rslt,"dev") == 0) {
8632 if (strncmp(cp2,"/null", 5) == 0) {
8633 if ((cp2[5] == 0) || (cp2[5] == '/')) {
8634 strcpy(rslt,"NLA0");
8638 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8644 trnend = islnm ? strlen(trndev) - 1 : 0;
8645 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8646 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8647 /* If the first element of the path is a logical name, determine
8648 * whether it has to be translated so we can add more directories. */
8649 if (!islnm || rooted) {
8652 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8656 if (cp2 != dirend) {
8657 strcpy(rslt,trndev);
8658 cp1 = rslt + trnend;
8665 if (decc_disable_posix_root) {
8671 PerlMem_free(trndev);
8676 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8677 cp2 += 2; /* skip over "./" - it's redundant */
8678 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8680 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8681 *(cp1++) = '-'; /* "../" --> "-" */
8684 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8685 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8686 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8687 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8690 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8691 /* Escape the extra dots in EFS file specifications */
8694 if (cp2 > dirend) cp2 = dirend;
8696 else *(cp1++) = '.';
8698 for (; cp2 < dirend; cp2++) {
8700 if (*(cp2-1) == '/') continue;
8701 if (*(cp1-1) != '.') *(cp1++) = '.';
8704 else if (!infront && *cp2 == '.') {
8705 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8706 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
8707 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8708 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8709 else if (*(cp1-2) == '[') *(cp1-1) = '-';
8710 else { /* back up over previous directory name */
8712 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8713 if (*(cp1-1) == '[') {
8714 memcpy(cp1,"000000.",7);
8719 if (cp2 == dirend) break;
8721 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8722 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8723 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8724 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8726 *(cp1++) = '.'; /* Simulate trailing '/' */
8727 cp2 += 2; /* for loop will incr this to == dirend */
8729 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8732 if (decc_efs_charset == 0)
8733 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8735 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8741 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
8743 if (decc_efs_charset == 0)
8750 else *(cp1++) = *cp2;
8754 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8755 if (hasdir) *(cp1++) = ']';
8756 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
8757 /* fixme for ODS5 */
8764 if (decc_efs_charset == 0)
8775 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8776 decc_readdir_dropdotnotype) {
8781 /* trailing dot ==> '^..' on VMS */
8788 *(cp1++) = *(cp2++);
8793 /* This could be a macro to be passed through */
8794 *(cp1++) = *(cp2++);
8796 const char * save_cp2;
8800 /* paranoid check */
8806 *(cp1++) = *(cp2++);
8807 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8808 *(cp1++) = *(cp2++);
8809 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8810 *(cp1++) = *(cp2++);
8813 *(cp1++) = *(cp2++);
8817 if (is_macro == 0) {
8818 /* Not really a macro - never mind */
8831 /* Don't escape again if following character is
8832 * already something we escape.
8834 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8835 *(cp1++) = *(cp2++);
8838 /* But otherwise fall through and escape it. */
8856 *(cp1++) = *(cp2++);
8859 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8860 * which is wrong. UNIX notation should be ".dir." unless
8861 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8862 * changing this behavior could break more things at this time.
8863 * efs character set effectively does not allow "." to be a version
8864 * delimiter as a further complication about changing this.
8866 if (decc_filename_unix_report != 0) {
8869 *(cp1++) = *(cp2++);
8872 *(cp1++) = *(cp2++);
8875 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8879 /* Fix me for "^]", but that requires making sure that you do
8880 * not back up past the start of the filename
8882 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8887 if (utf8_flag != NULL)
8889 if (vms_debug_fileify) {
8890 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8894 } /* end of int_tovmsspec() */
8897 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8898 static char *mp_do_tovmsspec
8899 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8900 static char __tovmsspec_retbuf[VMS_MAXRSS];
8901 char * vmsspec, *ret_spec, *ret_buf;
8905 if (ret_buf == NULL) {
8907 Newx(vmsspec, VMS_MAXRSS, char);
8908 if (vmsspec == NULL)
8909 _ckvmssts(SS$_INSFMEM);
8912 ret_buf = __tovmsspec_retbuf;
8916 ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8918 if (ret_spec == NULL) {
8919 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8926 } /* end of mp_do_tovmsspec() */
8928 /* External entry points */
8929 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8930 { return do_tovmsspec(path,buf,0,NULL); }
8931 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8932 { return do_tovmsspec(path,buf,1,NULL); }
8933 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8934 { return do_tovmsspec(path,buf,0,utf8_fl); }
8935 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8936 { return do_tovmsspec(path,buf,1,utf8_fl); }
8938 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8939 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8940 static char __tovmspath_retbuf[VMS_MAXRSS];
8942 char *pathified, *vmsified, *cp;
8944 if (path == NULL) return NULL;
8945 pathified = PerlMem_malloc(VMS_MAXRSS);
8946 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8947 if (int_pathify_dirspec(path, pathified) == NULL) {
8948 PerlMem_free(pathified);
8954 Newx(vmsified, VMS_MAXRSS, char);
8955 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8956 PerlMem_free(pathified);
8957 if (vmsified) Safefree(vmsified);
8960 PerlMem_free(pathified);
8965 vmslen = strlen(vmsified);
8966 Newx(cp,vmslen+1,char);
8967 memcpy(cp,vmsified,vmslen);
8973 strcpy(__tovmspath_retbuf,vmsified);
8975 return __tovmspath_retbuf;
8978 } /* end of do_tovmspath() */
8980 /* External entry points */
8981 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8982 { return do_tovmspath(path,buf,0, NULL); }
8983 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8984 { return do_tovmspath(path,buf,1, NULL); }
8985 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8986 { return do_tovmspath(path,buf,0,utf8_fl); }
8987 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8988 { return do_tovmspath(path,buf,1,utf8_fl); }
8991 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8992 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8993 static char __tounixpath_retbuf[VMS_MAXRSS];
8995 char *pathified, *unixified, *cp;
8997 if (path == NULL) return NULL;
8998 pathified = PerlMem_malloc(VMS_MAXRSS);
8999 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9000 if (int_pathify_dirspec(path, pathified) == NULL) {
9001 PerlMem_free(pathified);
9007 Newx(unixified, VMS_MAXRSS, char);
9009 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9010 PerlMem_free(pathified);
9011 if (unixified) Safefree(unixified);
9014 PerlMem_free(pathified);
9019 unixlen = strlen(unixified);
9020 Newx(cp,unixlen+1,char);
9021 memcpy(cp,unixified,unixlen);
9023 Safefree(unixified);
9027 strcpy(__tounixpath_retbuf,unixified);
9028 Safefree(unixified);
9029 return __tounixpath_retbuf;
9032 } /* end of do_tounixpath() */
9034 /* External entry points */
9035 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
9036 { return do_tounixpath(path,buf,0,NULL); }
9037 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9038 { return do_tounixpath(path,buf,1,NULL); }
9039 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9040 { return do_tounixpath(path,buf,0,utf8_fl); }
9041 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9042 { return do_tounixpath(path,buf,1,utf8_fl); }
9045 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
9047 *****************************************************************************
9049 * Copyright (C) 1989-1994, 2007 by *
9050 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
9052 * Permission is hereby granted for the reproduction of this software *
9053 * on condition that this copyright notice is included in source *
9054 * distributions of the software. The code may be modified and *
9055 * distributed under the same terms as Perl itself. *
9057 * 27-Aug-1994 Modified for inclusion in perl5 *
9058 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
9059 *****************************************************************************
9063 * getredirection() is intended to aid in porting C programs
9064 * to VMS (Vax-11 C). The native VMS environment does not support
9065 * '>' and '<' I/O redirection, or command line wild card expansion,
9066 * or a command line pipe mechanism using the '|' AND background
9067 * command execution '&'. All of these capabilities are provided to any
9068 * C program which calls this procedure as the first thing in the
9070 * The piping mechanism will probably work with almost any 'filter' type
9071 * of program. With suitable modification, it may useful for other
9072 * portability problems as well.
9074 * Author: Mark Pizzolato (mark AT infocomm DOT com)
9078 struct list_item *next;
9082 static void add_item(struct list_item **head,
9083 struct list_item **tail,
9087 static void mp_expand_wild_cards(pTHX_ char *item,
9088 struct list_item **head,
9089 struct list_item **tail,
9092 static int background_process(pTHX_ int argc, char **argv);
9094 static void pipe_and_fork(pTHX_ char **cmargv);
9096 /*{{{ void getredirection(int *ac, char ***av)*/
9098 mp_getredirection(pTHX_ int *ac, char ***av)
9100 * Process vms redirection arg's. Exit if any error is seen.
9101 * If getredirection() processes an argument, it is erased
9102 * from the vector. getredirection() returns a new argc and argv value.
9103 * In the event that a background command is requested (by a trailing "&"),
9104 * this routine creates a background subprocess, and simply exits the program.
9106 * Warning: do not try to simplify the code for vms. The code
9107 * presupposes that getredirection() is called before any data is
9108 * read from stdin or written to stdout.
9110 * Normal usage is as follows:
9116 * getredirection(&argc, &argv);
9120 int argc = *ac; /* Argument Count */
9121 char **argv = *av; /* Argument Vector */
9122 char *ap; /* Argument pointer */
9123 int j; /* argv[] index */
9124 int item_count = 0; /* Count of Items in List */
9125 struct list_item *list_head = 0; /* First Item in List */
9126 struct list_item *list_tail; /* Last Item in List */
9127 char *in = NULL; /* Input File Name */
9128 char *out = NULL; /* Output File Name */
9129 char *outmode = "w"; /* Mode to Open Output File */
9130 char *err = NULL; /* Error File Name */
9131 char *errmode = "w"; /* Mode to Open Error File */
9132 int cmargc = 0; /* Piped Command Arg Count */
9133 char **cmargv = NULL;/* Piped Command Arg Vector */
9136 * First handle the case where the last thing on the line ends with
9137 * a '&'. This indicates the desire for the command to be run in a
9138 * subprocess, so we satisfy that desire.
9141 if (0 == strcmp("&", ap))
9142 exit(background_process(aTHX_ --argc, argv));
9143 if (*ap && '&' == ap[strlen(ap)-1])
9145 ap[strlen(ap)-1] = '\0';
9146 exit(background_process(aTHX_ argc, argv));
9149 * Now we handle the general redirection cases that involve '>', '>>',
9150 * '<', and pipes '|'.
9152 for (j = 0; j < argc; ++j)
9154 if (0 == strcmp("<", argv[j]))
9158 fprintf(stderr,"No input file after < on command line");
9159 exit(LIB$_WRONUMARG);
9164 if ('<' == *(ap = argv[j]))
9169 if (0 == strcmp(">", ap))
9173 fprintf(stderr,"No output file after > on command line");
9174 exit(LIB$_WRONUMARG);
9193 fprintf(stderr,"No output file after > or >> on command line");
9194 exit(LIB$_WRONUMARG);
9198 if (('2' == *ap) && ('>' == ap[1]))
9215 fprintf(stderr,"No output file after 2> or 2>> on command line");
9216 exit(LIB$_WRONUMARG);
9220 if (0 == strcmp("|", argv[j]))
9224 fprintf(stderr,"No command into which to pipe on command line");
9225 exit(LIB$_WRONUMARG);
9227 cmargc = argc-(j+1);
9228 cmargv = &argv[j+1];
9232 if ('|' == *(ap = argv[j]))
9240 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9243 * Allocate and fill in the new argument vector, Some Unix's terminate
9244 * the list with an extra null pointer.
9246 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9247 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9249 for (j = 0; j < item_count; ++j, list_head = list_head->next)
9250 argv[j] = list_head->value;
9256 fprintf(stderr,"'|' and '>' may not both be specified on command line");
9257 exit(LIB$_INVARGORD);
9259 pipe_and_fork(aTHX_ cmargv);
9262 /* Check for input from a pipe (mailbox) */
9264 if (in == NULL && 1 == isapipe(0))
9266 char mbxname[L_tmpnam];
9268 long int dvi_item = DVI$_DEVBUFSIZ;
9269 $DESCRIPTOR(mbxnam, "");
9270 $DESCRIPTOR(mbxdevnam, "");
9272 /* Input from a pipe, reopen it in binary mode to disable */
9273 /* carriage control processing. */
9275 fgetname(stdin, mbxname);
9276 mbxnam.dsc$a_pointer = mbxname;
9277 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9278 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9279 mbxdevnam.dsc$a_pointer = mbxname;
9280 mbxdevnam.dsc$w_length = sizeof(mbxname);
9281 dvi_item = DVI$_DEVNAM;
9282 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9283 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9286 freopen(mbxname, "rb", stdin);
9289 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9293 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9295 fprintf(stderr,"Can't open input file %s as stdin",in);
9298 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9300 fprintf(stderr,"Can't open output file %s as stdout",out);
9303 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9306 if (strcmp(err,"&1") == 0) {
9307 dup2(fileno(stdout), fileno(stderr));
9308 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9311 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9313 fprintf(stderr,"Can't open error file %s as stderr",err);
9317 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9321 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9324 #ifdef ARGPROC_DEBUG
9325 PerlIO_printf(Perl_debug_log, "Arglist:\n");
9326 for (j = 0; j < *ac; ++j)
9327 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9329 /* Clear errors we may have hit expanding wildcards, so they don't
9330 show up in Perl's $! later */
9331 set_errno(0); set_vaxc_errno(1);
9332 } /* end of getredirection() */
9335 static void add_item(struct list_item **head,
9336 struct list_item **tail,
9342 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9343 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9347 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9348 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9349 *tail = (*tail)->next;
9351 (*tail)->value = value;
9355 static void mp_expand_wild_cards(pTHX_ char *item,
9356 struct list_item **head,
9357 struct list_item **tail,
9361 unsigned long int context = 0;
9369 $DESCRIPTOR(filespec, "");
9370 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9371 $DESCRIPTOR(resultspec, "");
9372 unsigned long int lff_flags = 0;
9376 #ifdef VMS_LONGNAME_SUPPORT
9377 lff_flags = LIB$M_FIL_LONG_NAMES;
9380 for (cp = item; *cp; cp++) {
9381 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9382 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9384 if (!*cp || isspace(*cp))
9386 add_item(head, tail, item, count);
9391 /* "double quoted" wild card expressions pass as is */
9392 /* From DCL that means using e.g.: */
9393 /* perl program """perl.*""" */
9394 item_len = strlen(item);
9395 if ( '"' == *item && '"' == item[item_len-1] )
9398 item[item_len-2] = '\0';
9399 add_item(head, tail, item, count);
9403 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9404 resultspec.dsc$b_class = DSC$K_CLASS_D;
9405 resultspec.dsc$a_pointer = NULL;
9406 vmsspec = PerlMem_malloc(VMS_MAXRSS);
9407 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9408 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9409 filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9410 if (!isunix || !filespec.dsc$a_pointer)
9411 filespec.dsc$a_pointer = item;
9412 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9414 * Only return version specs, if the caller specified a version
9416 had_version = strchr(item, ';');
9418 * Only return device and directory specs, if the caller specifed either.
9420 had_device = strchr(item, ':');
9421 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9423 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9424 (&filespec, &resultspec, &context,
9425 &defaultspec, 0, &rms_sts, &lff_flags)))
9430 string = PerlMem_malloc(resultspec.dsc$w_length+1);
9431 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9432 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9433 string[resultspec.dsc$w_length] = '\0';
9434 if (NULL == had_version)
9435 *(strrchr(string, ';')) = '\0';
9436 if ((!had_directory) && (had_device == NULL))
9438 if (NULL == (devdir = strrchr(string, ']')))
9439 devdir = strrchr(string, '>');
9440 strcpy(string, devdir + 1);
9443 * Be consistent with what the C RTL has already done to the rest of
9444 * the argv items and lowercase all of these names.
9446 if (!decc_efs_case_preserve) {
9447 for (c = string; *c; ++c)
9451 if (isunix) trim_unixpath(string,item,1);
9452 add_item(head, tail, string, count);
9455 PerlMem_free(vmsspec);
9456 if (sts != RMS$_NMF)
9458 set_vaxc_errno(sts);
9461 case RMS$_FNF: case RMS$_DNF:
9462 set_errno(ENOENT); break;
9464 set_errno(ENOTDIR); break;
9466 set_errno(ENODEV); break;
9467 case RMS$_FNM: case RMS$_SYN:
9468 set_errno(EINVAL); break;
9470 set_errno(EACCES); break;
9472 _ckvmssts_noperl(sts);
9476 add_item(head, tail, item, count);
9477 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9478 _ckvmssts_noperl(lib$find_file_end(&context));
9481 static int child_st[2];/* Event Flag set when child process completes */
9483 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
9485 static unsigned long int exit_handler(int *status)
9489 if (0 == child_st[0])
9491 #ifdef ARGPROC_DEBUG
9492 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9494 fflush(stdout); /* Have to flush pipe for binary data to */
9495 /* terminate properly -- <tp@mccall.com> */
9496 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9497 sys$dassgn(child_chan);
9499 sys$synch(0, child_st);
9504 static void sig_child(int chan)
9506 #ifdef ARGPROC_DEBUG
9507 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9509 if (child_st[0] == 0)
9513 static struct exit_control_block exit_block =
9518 &exit_block.exit_status,
9523 pipe_and_fork(pTHX_ char **cmargv)
9526 struct dsc$descriptor_s *vmscmd;
9527 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9528 int sts, j, l, ismcr, quote, tquote = 0;
9530 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
9531 vms_execfree(vmscmd);
9536 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
9537 && toupper(*(q+2)) == 'R' && !*(q+3);
9539 while (q && l < MAX_DCL_LINE_LENGTH) {
9541 if (j > 0 && quote) {
9547 if (ismcr && j > 1) quote = 1;
9548 tquote = (strchr(q,' ')) != NULL || *q == '\0';
9551 if (quote || tquote) {
9557 if ((quote||tquote) && *q == '"') {
9567 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9569 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9573 static int background_process(pTHX_ int argc, char **argv)
9575 char command[MAX_DCL_SYMBOL + 1] = "$";
9576 $DESCRIPTOR(value, "");
9577 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9578 static $DESCRIPTOR(null, "NLA0:");
9579 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9581 $DESCRIPTOR(pidstr, "");
9583 unsigned long int flags = 17, one = 1, retsts;
9586 strcat(command, argv[0]);
9587 len = strlen(command);
9588 while (--argc && (len < MAX_DCL_SYMBOL))
9590 strcat(command, " \"");
9591 strcat(command, *(++argv));
9592 strcat(command, "\"");
9593 len = strlen(command);
9595 value.dsc$a_pointer = command;
9596 value.dsc$w_length = strlen(value.dsc$a_pointer);
9597 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9598 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9599 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9600 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9603 _ckvmssts_noperl(retsts);
9605 #ifdef ARGPROC_DEBUG
9606 PerlIO_printf(Perl_debug_log, "%s\n", command);
9608 sprintf(pidstring, "%08X", pid);
9609 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9610 pidstr.dsc$a_pointer = pidstring;
9611 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9612 lib$set_symbol(&pidsymbol, &pidstr);
9616 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9619 /* OS-specific initialization at image activation (not thread startup) */
9620 /* Older VAXC header files lack these constants */
9621 #ifndef JPI$_RIGHTS_SIZE
9622 # define JPI$_RIGHTS_SIZE 817
9624 #ifndef KGB$M_SUBSYSTEM
9625 # define KGB$M_SUBSYSTEM 0x8
9628 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9630 /*{{{void vms_image_init(int *, char ***)*/
9632 vms_image_init(int *argcp, char ***argvp)
9635 char eqv[LNM$C_NAMLENGTH+1] = "";
9636 unsigned int len, tabct = 8, tabidx = 0;
9637 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9638 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9639 unsigned short int dummy, rlen;
9640 struct dsc$descriptor_s **tabvec;
9641 #if defined(PERL_IMPLICIT_CONTEXT)
9644 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
9645 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
9646 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9649 #ifdef KILL_BY_SIGPRC
9650 Perl_csighandler_init();
9653 /* This was moved from the pre-image init handler because on threaded */
9654 /* Perl it was always returning 0 for the default value. */
9655 status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9658 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9661 initial = decc$feature_get_value(s, 4);
9663 /* initial is: 0 if nothing has set the feature */
9664 /* -1 if initialized to default */
9665 /* 1 if set by logical name */
9666 /* 2 if set by decc$feature_set_value */
9667 decc_disable_posix_root = decc$feature_get_value(s, 1);
9669 /* If the value is not valid, force the feature off */
9670 if (decc_disable_posix_root < 0) {
9671 decc$feature_set_value(s, 1, 1);
9672 decc_disable_posix_root = 1;
9676 /* Nothing has asked for it explicitly, so use our own default. */
9677 decc_disable_posix_root = 1;
9678 decc$feature_set_value(s, 1, 1);
9684 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9685 _ckvmssts_noperl(iosb[0]);
9686 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9687 if (iprv[i]) { /* Running image installed with privs? */
9688 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
9693 /* Rights identifiers might trigger tainting as well. */
9694 if (!will_taint && (rlen || rsz)) {
9695 while (rlen < rsz) {
9696 /* We didn't get all the identifiers on the first pass. Allocate a
9697 * buffer much larger than $GETJPI wants (rsz is size in bytes that
9698 * were needed to hold all identifiers at time of last call; we'll
9699 * allocate that many unsigned long ints), and go back and get 'em.
9700 * If it gave us less than it wanted to despite ample buffer space,
9701 * something's broken. Is your system missing a system identifier?
9703 if (rsz <= jpilist[1].buflen) {
9704 /* Perl_croak accvios when used this early in startup. */
9705 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9706 rsz, (unsigned long) jpilist[1].buflen,
9707 "Check your rights database for corruption.\n");
9710 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9711 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9712 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9713 jpilist[1].buflen = rsz * sizeof(unsigned long int);
9714 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9715 _ckvmssts_noperl(iosb[0]);
9717 mask = jpilist[1].bufadr;
9718 /* Check attribute flags for each identifier (2nd longword); protected
9719 * subsystem identifiers trigger tainting.
9721 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9722 if (mask[i] & KGB$M_SUBSYSTEM) {
9727 if (mask != rlst) PerlMem_free(mask);
9730 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9731 * logical, some versions of the CRTL will add a phanthom /000000/
9732 * directory. This needs to be removed.
9734 if (decc_filename_unix_report) {
9737 ulen = strlen(argvp[0][0]);
9739 zeros = strstr(argvp[0][0], "/000000/");
9740 if (zeros != NULL) {
9742 mlen = ulen - (zeros - argvp[0][0]) - 7;
9743 memmove(zeros, &zeros[7], mlen);
9745 argvp[0][0][ulen] = '\0';
9748 /* It also may have a trailing dot that needs to be removed otherwise
9749 * it will be converted to VMS mode incorrectly.
9752 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9753 argvp[0][0][ulen] = '\0';
9756 /* We need to use this hack to tell Perl it should run with tainting,
9757 * since its tainting flag may be part of the PL_curinterp struct, which
9758 * hasn't been allocated when vms_image_init() is called.
9761 char **newargv, **oldargv;
9763 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9764 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9765 newargv[0] = oldargv[0];
9766 newargv[1] = PerlMem_malloc(3 * sizeof(char));
9767 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9768 strcpy(newargv[1], "-T");
9769 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9771 newargv[*argcp] = NULL;
9772 /* We orphan the old argv, since we don't know where it's come from,
9773 * so we don't know how to free it.
9777 else { /* Did user explicitly request tainting? */
9779 char *cp, **av = *argvp;
9780 for (i = 1; i < *argcp; i++) {
9781 if (*av[i] != '-') break;
9782 for (cp = av[i]+1; *cp; cp++) {
9783 if (*cp == 'T') { will_taint = 1; break; }
9784 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9785 strchr("DFIiMmx",*cp)) break;
9787 if (will_taint) break;
9792 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9795 tabvec = (struct dsc$descriptor_s **)
9796 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9797 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9799 else if (tabidx >= tabct) {
9801 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9802 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9804 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9805 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9806 tabvec[tabidx]->dsc$w_length = 0;
9807 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9808 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9809 tabvec[tabidx]->dsc$a_pointer = NULL;
9810 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9812 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9814 getredirection(argcp,argvp);
9815 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9817 # include <reentrancy.h>
9818 decc$set_reentrancy(C$C_MULTITHREAD);
9827 * Trim Unix-style prefix off filespec, so it looks like what a shell
9828 * glob expansion would return (i.e. from specified prefix on, not
9829 * full path). Note that returned filespec is Unix-style, regardless
9830 * of whether input filespec was VMS-style or Unix-style.
9832 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9833 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9834 * vector of options; at present, only bit 0 is used, and if set tells
9835 * trim unixpath to try the current default directory as a prefix when
9836 * presented with a possibly ambiguous ... wildcard.
9838 * Returns !=0 on success, with trimmed filespec replacing contents of
9839 * fspec, and 0 on failure, with contents of fpsec unchanged.
9841 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9843 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9845 char *unixified, *unixwild,
9846 *template, *base, *end, *cp1, *cp2;
9847 register int tmplen, reslen = 0, dirs = 0;
9849 if (!wildspec || !fspec) return 0;
9851 unixwild = PerlMem_malloc(VMS_MAXRSS);
9852 if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9853 template = unixwild;
9854 if (strpbrk(wildspec,"]>:") != NULL) {
9855 if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9856 PerlMem_free(unixwild);
9861 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9862 unixwild[VMS_MAXRSS-1] = 0;
9864 unixified = PerlMem_malloc(VMS_MAXRSS);
9865 if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9866 if (strpbrk(fspec,"]>:") != NULL) {
9867 if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9868 PerlMem_free(unixwild);
9869 PerlMem_free(unixified);
9872 else base = unixified;
9873 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9874 * check to see that final result fits into (isn't longer than) fspec */
9875 reslen = strlen(fspec);
9879 /* No prefix or absolute path on wildcard, so nothing to remove */
9880 if (!*template || *template == '/') {
9881 PerlMem_free(unixwild);
9882 if (base == fspec) {
9883 PerlMem_free(unixified);
9886 tmplen = strlen(unixified);
9887 if (tmplen > reslen) {
9888 PerlMem_free(unixified);
9889 return 0; /* not enough space */
9891 /* Copy unixified resultant, including trailing NUL */
9892 memmove(fspec,unixified,tmplen+1);
9893 PerlMem_free(unixified);
9897 for (end = base; *end; end++) ; /* Find end of resultant filespec */
9898 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9899 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9900 for (cp1 = end ;cp1 >= base; cp1--)
9901 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9903 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9904 PerlMem_free(unixified);
9905 PerlMem_free(unixwild);
9910 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9911 int ells = 1, totells, segdirs, match;
9912 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9913 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9915 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9917 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9918 tpl = PerlMem_malloc(VMS_MAXRSS);
9919 if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9920 if (ellipsis == template && opts & 1) {
9921 /* Template begins with an ellipsis. Since we can't tell how many
9922 * directory names at the front of the resultant to keep for an
9923 * arbitrary starting point, we arbitrarily choose the current
9924 * default directory as a starting point. If it's there as a prefix,
9925 * clip it off. If not, fall through and act as if the leading
9926 * ellipsis weren't there (i.e. return shortest possible path that
9927 * could match template).
9929 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9931 PerlMem_free(unixified);
9932 PerlMem_free(unixwild);
9935 if (!decc_efs_case_preserve) {
9936 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9937 if (_tolower(*cp1) != _tolower(*cp2)) break;
9939 segdirs = dirs - totells; /* Min # of dirs we must have left */
9940 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9941 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9942 memmove(fspec,cp2+1,end - cp2);
9944 PerlMem_free(unixified);
9945 PerlMem_free(unixwild);
9949 /* First off, back up over constant elements at end of path */
9951 for (front = end ; front >= base; front--)
9952 if (*front == '/' && !dirs--) { front++; break; }
9954 lcres = PerlMem_malloc(VMS_MAXRSS);
9955 if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9956 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9958 if (!decc_efs_case_preserve) {
9959 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9967 PerlMem_free(unixified);
9968 PerlMem_free(unixwild);
9969 PerlMem_free(lcres);
9970 return 0; /* Path too long. */
9973 *cp2 = '\0'; /* Pick up with memcpy later */
9974 lcfront = lcres + (front - base);
9975 /* Now skip over each ellipsis and try to match the path in front of it. */
9977 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9978 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9979 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
9980 if (cp1 < template) break; /* template started with an ellipsis */
9981 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9982 ellipsis = cp1; continue;
9984 wilddsc.dsc$a_pointer = tpl;
9985 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9987 for (segdirs = 0, cp2 = tpl;
9988 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9990 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9992 if (!decc_efs_case_preserve) {
9993 *cp2 = _tolower(*cp1); /* else lowercase for match */
9996 *cp2 = *cp1; /* else preserve case for match */
9999 if (*cp2 == '/') segdirs++;
10001 if (cp1 != ellipsis - 1) {
10003 PerlMem_free(unixified);
10004 PerlMem_free(unixwild);
10005 PerlMem_free(lcres);
10006 return 0; /* Path too long */
10008 /* Back up at least as many dirs as in template before matching */
10009 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10010 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10011 for (match = 0; cp1 > lcres;) {
10012 resdsc.dsc$a_pointer = cp1;
10013 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10015 if (match == 1) lcfront = cp1;
10017 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10021 PerlMem_free(unixified);
10022 PerlMem_free(unixwild);
10023 PerlMem_free(lcres);
10024 return 0; /* Can't find prefix ??? */
10026 if (match > 1 && opts & 1) {
10027 /* This ... wildcard could cover more than one set of dirs (i.e.
10028 * a set of similar dir names is repeated). If the template
10029 * contains more than 1 ..., upstream elements could resolve the
10030 * ambiguity, but it's not worth a full backtracking setup here.
10031 * As a quick heuristic, clip off the current default directory
10032 * if it's present to find the trimmed spec, else use the
10033 * shortest string that this ... could cover.
10035 char def[NAM$C_MAXRSS+1], *st;
10037 if (getcwd(def, sizeof def,0) == NULL) {
10038 PerlMem_free(unixified);
10039 PerlMem_free(unixwild);
10040 PerlMem_free(lcres);
10044 if (!decc_efs_case_preserve) {
10045 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10046 if (_tolower(*cp1) != _tolower(*cp2)) break;
10048 segdirs = dirs - totells; /* Min # of dirs we must have left */
10049 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10050 if (*cp1 == '\0' && *cp2 == '/') {
10051 memmove(fspec,cp2+1,end - cp2);
10053 PerlMem_free(unixified);
10054 PerlMem_free(unixwild);
10055 PerlMem_free(lcres);
10058 /* Nope -- stick with lcfront from above and keep going. */
10061 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10063 PerlMem_free(unixified);
10064 PerlMem_free(unixwild);
10065 PerlMem_free(lcres);
10067 ellipsis = nextell;
10070 } /* end of trim_unixpath() */
10075 * VMS readdir() routines.
10076 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10078 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
10079 * Minor modifications to original routines.
10082 /* readdir may have been redefined by reentr.h, so make sure we get
10083 * the local version for what we do here.
10088 #if !defined(PERL_IMPLICIT_CONTEXT)
10089 # define readdir Perl_readdir
10091 # define readdir(a) Perl_readdir(aTHX_ a)
10094 /* Number of elements in vms_versions array */
10095 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
10098 * Open a directory, return a handle for later use.
10100 /*{{{ DIR *opendir(char*name) */
10102 Perl_opendir(pTHX_ const char *name)
10108 Newx(dir, VMS_MAXRSS, char);
10109 if (do_tovmspath(name,dir,0,NULL) == NULL) {
10113 /* Check access before stat; otherwise stat does not
10114 * accurately report whether it's a directory.
10116 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10117 /* cando_by_name has already set errno */
10121 if (flex_stat(dir,&sb) == -1) return NULL;
10122 if (!S_ISDIR(sb.st_mode)) {
10124 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
10127 /* Get memory for the handle, and the pattern. */
10129 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10131 /* Fill in the fields; mainly playing with the descriptor. */
10132 sprintf(dd->pattern, "%s*.*",dir);
10137 /* By saying we always want the result of readdir() in unix format, we
10138 * are really saying we want all the escapes removed. Otherwise the caller,
10139 * having no way to know whether it's already in VMS format, might send it
10140 * through tovmsspec again, thus double escaping.
10142 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10143 dd->pat.dsc$a_pointer = dd->pattern;
10144 dd->pat.dsc$w_length = strlen(dd->pattern);
10145 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10146 dd->pat.dsc$b_class = DSC$K_CLASS_S;
10147 #if defined(USE_ITHREADS)
10148 Newx(dd->mutex,1,perl_mutex);
10149 MUTEX_INIT( (perl_mutex *) dd->mutex );
10155 } /* end of opendir() */
10159 * Set the flag to indicate we want versions or not.
10161 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10163 vmsreaddirversions(DIR *dd, int flag)
10166 dd->flags |= PERL_VMSDIR_M_VERSIONS;
10168 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10173 * Free up an opened directory.
10175 /*{{{ void closedir(DIR *dd)*/
10177 Perl_closedir(DIR *dd)
10181 sts = lib$find_file_end(&dd->context);
10182 Safefree(dd->pattern);
10183 #if defined(USE_ITHREADS)
10184 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10185 Safefree(dd->mutex);
10192 * Collect all the version numbers for the current file.
10195 collectversions(pTHX_ DIR *dd)
10197 struct dsc$descriptor_s pat;
10198 struct dsc$descriptor_s res;
10200 char *p, *text, *buff;
10202 unsigned long context, tmpsts;
10204 /* Convenient shorthand. */
10207 /* Add the version wildcard, ignoring the "*.*" put on before */
10208 i = strlen(dd->pattern);
10209 Newx(text,i + e->d_namlen + 3,char);
10210 strcpy(text, dd->pattern);
10211 sprintf(&text[i - 3], "%s;*", e->d_name);
10213 /* Set up the pattern descriptor. */
10214 pat.dsc$a_pointer = text;
10215 pat.dsc$w_length = i + e->d_namlen - 1;
10216 pat.dsc$b_dtype = DSC$K_DTYPE_T;
10217 pat.dsc$b_class = DSC$K_CLASS_S;
10219 /* Set up result descriptor. */
10220 Newx(buff, VMS_MAXRSS, char);
10221 res.dsc$a_pointer = buff;
10222 res.dsc$w_length = VMS_MAXRSS - 1;
10223 res.dsc$b_dtype = DSC$K_DTYPE_T;
10224 res.dsc$b_class = DSC$K_CLASS_S;
10226 /* Read files, collecting versions. */
10227 for (context = 0, e->vms_verscount = 0;
10228 e->vms_verscount < VERSIZE(e);
10229 e->vms_verscount++) {
10230 unsigned long rsts;
10231 unsigned long flags = 0;
10233 #ifdef VMS_LONGNAME_SUPPORT
10234 flags = LIB$M_FIL_LONG_NAMES;
10236 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10237 if (tmpsts == RMS$_NMF || context == 0) break;
10239 buff[VMS_MAXRSS - 1] = '\0';
10240 if ((p = strchr(buff, ';')))
10241 e->vms_versions[e->vms_verscount] = atoi(p + 1);
10243 e->vms_versions[e->vms_verscount] = -1;
10246 _ckvmssts(lib$find_file_end(&context));
10250 } /* end of collectversions() */
10253 * Read the next entry from the directory.
10255 /*{{{ struct dirent *readdir(DIR *dd)*/
10257 Perl_readdir(pTHX_ DIR *dd)
10259 struct dsc$descriptor_s res;
10261 unsigned long int tmpsts;
10262 unsigned long rsts;
10263 unsigned long flags = 0;
10264 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10265 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10267 /* Set up result descriptor, and get next file. */
10268 Newx(buff, VMS_MAXRSS, char);
10269 res.dsc$a_pointer = buff;
10270 res.dsc$w_length = VMS_MAXRSS - 1;
10271 res.dsc$b_dtype = DSC$K_DTYPE_T;
10272 res.dsc$b_class = DSC$K_CLASS_S;
10274 #ifdef VMS_LONGNAME_SUPPORT
10275 flags = LIB$M_FIL_LONG_NAMES;
10278 tmpsts = lib$find_file
10279 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10280 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
10281 if (!(tmpsts & 1)) {
10282 set_vaxc_errno(tmpsts);
10285 set_errno(EACCES); break;
10287 set_errno(ENODEV); break;
10289 set_errno(ENOTDIR); break;
10290 case RMS$_FNF: case RMS$_DNF:
10291 set_errno(ENOENT); break;
10293 set_errno(EVMSERR);
10299 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10300 buff[res.dsc$w_length] = '\0';
10301 p = buff + res.dsc$w_length;
10302 while (--p >= buff) if (!isspace(*p)) break;
10304 if (!decc_efs_case_preserve) {
10305 for (p = buff; *p; p++) *p = _tolower(*p);
10308 /* Skip any directory component and just copy the name. */
10309 sts = vms_split_path
10324 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10326 /* In Unix report mode, remove the ".dir;1" from the name */
10327 /* if it is a real directory. */
10328 if (decc_filename_unix_report || decc_efs_charset) {
10329 if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
10330 if ((toupper(e_spec[1]) == 'D') &&
10331 (toupper(e_spec[2]) == 'I') &&
10332 (toupper(e_spec[3]) == 'R')) {
10336 ret_sts = stat(buff, (stat_t *)&statbuf);
10337 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10345 /* Drop NULL extensions on UNIX file specification */
10346 if ((e_len == 1) && decc_readdir_dropdotnotype) {
10352 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10353 dd->entry.d_name[n_len + e_len] = '\0';
10354 dd->entry.d_namlen = strlen(dd->entry.d_name);
10356 /* Convert the filename to UNIX format if needed */
10357 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10359 /* Translate the encoded characters. */
10360 /* Fixme: Unicode handling could result in embedded 0 characters */
10361 if (strchr(dd->entry.d_name, '^') != NULL) {
10362 char new_name[256];
10364 p = dd->entry.d_name;
10367 int inchars_read, outchars_added;
10368 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10370 q += outchars_added;
10372 /* if outchars_added > 1, then this is a wide file specification */
10373 /* Wide file specifications need to be passed in Perl */
10374 /* counted strings apparently with a Unicode flag */
10377 strcpy(dd->entry.d_name, new_name);
10378 dd->entry.d_namlen = strlen(dd->entry.d_name);
10382 dd->entry.vms_verscount = 0;
10383 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10387 } /* end of readdir() */
10391 * Read the next entry from the directory -- thread-safe version.
10393 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10395 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10399 MUTEX_LOCK( (perl_mutex *) dd->mutex );
10401 entry = readdir(dd);
10403 retval = ( *result == NULL ? errno : 0 );
10405 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10409 } /* end of readdir_r() */
10413 * Return something that can be used in a seekdir later.
10415 /*{{{ long telldir(DIR *dd)*/
10417 Perl_telldir(DIR *dd)
10424 * Return to a spot where we used to be. Brute force.
10426 /*{{{ void seekdir(DIR *dd,long count)*/
10428 Perl_seekdir(pTHX_ DIR *dd, long count)
10432 /* If we haven't done anything yet... */
10433 if (dd->count == 0)
10436 /* Remember some state, and clear it. */
10437 old_flags = dd->flags;
10438 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10439 _ckvmssts(lib$find_file_end(&dd->context));
10442 /* The increment is in readdir(). */
10443 for (dd->count = 0; dd->count < count; )
10446 dd->flags = old_flags;
10448 } /* end of seekdir() */
10451 /* VMS subprocess management
10453 * my_vfork() - just a vfork(), after setting a flag to record that
10454 * the current script is trying a Unix-style fork/exec.
10456 * vms_do_aexec() and vms_do_exec() are called in response to the
10457 * perl 'exec' function. If this follows a vfork call, then they
10458 * call out the regular perl routines in doio.c which do an
10459 * execvp (for those who really want to try this under VMS).
10460 * Otherwise, they do exactly what the perl docs say exec should
10461 * do - terminate the current script and invoke a new command
10462 * (See below for notes on command syntax.)
10464 * do_aspawn() and do_spawn() implement the VMS side of the perl
10465 * 'system' function.
10467 * Note on command arguments to perl 'exec' and 'system': When handled
10468 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10469 * are concatenated to form a DCL command string. If the first non-numeric
10470 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10471 * the command string is handed off to DCL directly. Otherwise,
10472 * the first token of the command is taken as the filespec of an image
10473 * to run. The filespec is expanded using a default type of '.EXE' and
10474 * the process defaults for device, directory, etc., and if found, the resultant
10475 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10476 * the command string as parameters. This is perhaps a bit complicated,
10477 * but I hope it will form a happy medium between what VMS folks expect
10478 * from lib$spawn and what Unix folks expect from exec.
10481 static int vfork_called;
10483 /*{{{int my_vfork()*/
10494 vms_execfree(struct dsc$descriptor_s *vmscmd)
10497 if (vmscmd->dsc$a_pointer) {
10498 PerlMem_free(vmscmd->dsc$a_pointer);
10500 PerlMem_free(vmscmd);
10505 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10507 char *junk, *tmps = NULL;
10508 register size_t cmdlen = 0;
10515 tmps = SvPV(really,rlen);
10517 cmdlen += rlen + 1;
10522 for (idx++; idx <= sp; idx++) {
10524 junk = SvPVx(*idx,rlen);
10525 cmdlen += rlen ? rlen + 1 : 0;
10528 Newx(PL_Cmd, cmdlen+1, char);
10530 if (tmps && *tmps) {
10531 strcpy(PL_Cmd,tmps);
10534 else *PL_Cmd = '\0';
10535 while (++mark <= sp) {
10537 char *s = SvPVx(*mark,n_a);
10539 if (*PL_Cmd) strcat(PL_Cmd," ");
10545 } /* end of setup_argstr() */
10548 static unsigned long int
10549 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10550 struct dsc$descriptor_s **pvmscmd)
10554 char image_name[NAM$C_MAXRSS+1];
10555 char image_argv[NAM$C_MAXRSS+1];
10556 $DESCRIPTOR(defdsc,".EXE");
10557 $DESCRIPTOR(defdsc2,".");
10558 struct dsc$descriptor_s resdsc;
10559 struct dsc$descriptor_s *vmscmd;
10560 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10561 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10562 register char *s, *rest, *cp, *wordbreak;
10565 register int isdcl;
10567 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10568 if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10570 /* vmsspec is a DCL command buffer, not just a filename */
10571 vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10572 if (vmsspec == NULL)
10573 _ckvmssts_noperl(SS$_INSFMEM);
10575 resspec = PerlMem_malloc(VMS_MAXRSS);
10576 if (resspec == NULL)
10577 _ckvmssts_noperl(SS$_INSFMEM);
10579 /* Make a copy for modification */
10580 cmdlen = strlen(incmd);
10581 cmd = PerlMem_malloc(cmdlen+1);
10582 if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10583 strncpy(cmd, incmd, cmdlen);
10588 resdsc.dsc$a_pointer = resspec;
10589 resdsc.dsc$b_dtype = DSC$K_DTYPE_T;
10590 resdsc.dsc$b_class = DSC$K_CLASS_S;
10591 resdsc.dsc$w_length = VMS_MAXRSS - 1;
10593 vmscmd->dsc$a_pointer = NULL;
10594 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
10595 vmscmd->dsc$b_class = DSC$K_CLASS_S;
10596 vmscmd->dsc$w_length = 0;
10597 if (pvmscmd) *pvmscmd = vmscmd;
10599 if (suggest_quote) *suggest_quote = 0;
10601 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10603 PerlMem_free(vmsspec);
10604 PerlMem_free(resspec);
10605 return CLI$_BUFOVF; /* continuation lines currently unsupported */
10610 while (*s && isspace(*s)) s++;
10612 if (*s == '@' || *s == '$') {
10613 vmsspec[0] = *s; rest = s + 1;
10614 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10616 else { cp = vmsspec; rest = s; }
10617 if (*rest == '.' || *rest == '/') {
10619 for (cp2 = resspec;
10620 *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10621 rest++, cp2++) *cp2 = *rest;
10623 if (int_tovmsspec(resspec, cp, 0, NULL)) {
10626 /* When a UNIX spec with no file type is translated to VMS, */
10627 /* A trailing '.' is appended under ODS-5 rules. */
10628 /* Here we do not want that trailing "." as it prevents */
10629 /* Looking for a implied ".exe" type. */
10630 if (decc_efs_charset) {
10632 i = strlen(vmsspec);
10633 if (vmsspec[i-1] == '.') {
10634 vmsspec[i-1] = '\0';
10639 for (cp2 = vmsspec + strlen(vmsspec);
10640 *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10641 rest++, cp2++) *cp2 = *rest;
10646 /* Intuit whether verb (first word of cmd) is a DCL command:
10647 * - if first nonspace char is '@', it's a DCL indirection
10649 * - if verb contains a filespec separator, it's not a DCL command
10650 * - if it doesn't, caller tells us whether to default to a DCL
10651 * command, or to a local image unless told it's DCL (by leading '$')
10655 if (suggest_quote) *suggest_quote = 1;
10657 register char *filespec = strpbrk(s,":<[.;");
10658 rest = wordbreak = strpbrk(s," \"\t/");
10659 if (!wordbreak) wordbreak = s + strlen(s);
10660 if (*s == '$') check_img = 0;
10661 if (filespec && (filespec < wordbreak)) isdcl = 0;
10662 else isdcl = !check_img;
10667 imgdsc.dsc$a_pointer = s;
10668 imgdsc.dsc$w_length = wordbreak - s;
10669 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10671 _ckvmssts_noperl(lib$find_file_end(&cxt));
10672 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10673 if (!(retsts & 1) && *s == '$') {
10674 _ckvmssts_noperl(lib$find_file_end(&cxt));
10675 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10676 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10678 _ckvmssts_noperl(lib$find_file_end(&cxt));
10679 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10683 _ckvmssts_noperl(lib$find_file_end(&cxt));
10688 while (*s && !isspace(*s)) s++;
10691 /* check that it's really not DCL with no file extension */
10692 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10694 char b[256] = {0,0,0,0};
10695 read(fileno(fp), b, 256);
10696 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10700 /* Check for script */
10702 if ((b[0] == '#') && (b[1] == '!'))
10704 #ifdef ALTERNATE_SHEBANG
10706 shebang_len = strlen(ALTERNATE_SHEBANG);
10707 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10709 perlstr = strstr("perl",b);
10710 if (perlstr == NULL)
10718 if (shebang_len > 0) {
10721 char tmpspec[NAM$C_MAXRSS + 1];
10724 /* Image is following after white space */
10725 /*--------------------------------------*/
10726 while (isprint(b[i]) && isspace(b[i]))
10730 while (isprint(b[i]) && !isspace(b[i])) {
10731 tmpspec[j++] = b[i++];
10732 if (j >= NAM$C_MAXRSS)
10737 /* There may be some default parameters to the image */
10738 /*---------------------------------------------------*/
10740 while (isprint(b[i])) {
10741 image_argv[j++] = b[i++];
10742 if (j >= NAM$C_MAXRSS)
10745 while ((j > 0) && !isprint(image_argv[j-1]))
10749 /* It will need to be converted to VMS format and validated */
10750 if (tmpspec[0] != '\0') {
10753 /* Try to find the exact program requested to be run */
10754 /*---------------------------------------------------*/
10755 iname = int_rmsexpand
10756 (tmpspec, image_name, ".exe",
10757 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10758 if (iname != NULL) {
10759 if (cando_by_name_int
10760 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10761 /* MCR prefix needed */
10765 /* Try again with a null type */
10766 /*----------------------------*/
10767 iname = int_rmsexpand
10768 (tmpspec, image_name, ".",
10769 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10770 if (iname != NULL) {
10771 if (cando_by_name_int
10772 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10773 /* MCR prefix needed */
10779 /* Did we find the image to run the script? */
10780 /*------------------------------------------*/
10784 /* Assume DCL or foreign command exists */
10785 /*--------------------------------------*/
10786 tchr = strrchr(tmpspec, '/');
10787 if (tchr != NULL) {
10793 strcpy(image_name, tchr);
10801 if (check_img && isdcl) {
10803 PerlMem_free(resspec);
10804 PerlMem_free(vmsspec);
10808 if (cando_by_name(S_IXUSR,0,resspec)) {
10809 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10810 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10812 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10813 if (image_name[0] != 0) {
10814 strcat(vmscmd->dsc$a_pointer, image_name);
10815 strcat(vmscmd->dsc$a_pointer, " ");
10817 } else if (image_name[0] != 0) {
10818 strcpy(vmscmd->dsc$a_pointer, image_name);
10819 strcat(vmscmd->dsc$a_pointer, " ");
10821 strcpy(vmscmd->dsc$a_pointer,"@");
10823 if (suggest_quote) *suggest_quote = 1;
10825 /* If there is an image name, use original command */
10826 if (image_name[0] == 0)
10827 strcat(vmscmd->dsc$a_pointer,resspec);
10830 while (*rest && isspace(*rest)) rest++;
10833 if (image_argv[0] != 0) {
10834 strcat(vmscmd->dsc$a_pointer,image_argv);
10835 strcat(vmscmd->dsc$a_pointer, " ");
10841 rest_len = strlen(rest);
10842 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10843 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10844 strcat(vmscmd->dsc$a_pointer,rest);
10846 retsts = CLI$_BUFOVF;
10848 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10850 PerlMem_free(vmsspec);
10851 PerlMem_free(resspec);
10852 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10858 /* It's either a DCL command or we couldn't find a suitable image */
10859 vmscmd->dsc$w_length = strlen(cmd);
10861 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10862 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10863 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10866 PerlMem_free(resspec);
10867 PerlMem_free(vmsspec);
10869 /* check if it's a symbol (for quoting purposes) */
10870 if (suggest_quote && !*suggest_quote) {
10872 char equiv[LNM$C_NAMLENGTH];
10873 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10874 eqvdsc.dsc$a_pointer = equiv;
10876 iss = lib$get_symbol(vmscmd,&eqvdsc);
10877 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10879 if (!(retsts & 1)) {
10880 /* just hand off status values likely to be due to user error */
10881 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10882 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10883 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10884 else { _ckvmssts_noperl(retsts); }
10887 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10889 } /* end of setup_cmddsc() */
10892 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10894 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10900 if (vfork_called) { /* this follows a vfork - act Unixish */
10902 if (vfork_called < 0) {
10903 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10906 else return do_aexec(really,mark,sp);
10908 /* no vfork - act VMSish */
10909 cmd = setup_argstr(aTHX_ really,mark,sp);
10910 exec_sts = vms_do_exec(cmd);
10911 Safefree(cmd); /* Clean up from setup_argstr() */
10916 } /* end of vms_do_aexec() */
10919 /* {{{bool vms_do_exec(char *cmd) */
10921 Perl_vms_do_exec(pTHX_ const char *cmd)
10923 struct dsc$descriptor_s *vmscmd;
10925 if (vfork_called) { /* this follows a vfork - act Unixish */
10927 if (vfork_called < 0) {
10928 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10931 else return do_exec(cmd);
10934 { /* no vfork - act VMSish */
10935 unsigned long int retsts;
10938 TAINT_PROPER("exec");
10939 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10940 retsts = lib$do_command(vmscmd);
10943 case RMS$_FNF: case RMS$_DNF:
10944 set_errno(ENOENT); break;
10946 set_errno(ENOTDIR); break;
10948 set_errno(ENODEV); break;
10950 set_errno(EACCES); break;
10952 set_errno(EINVAL); break;
10953 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10954 set_errno(E2BIG); break;
10955 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10956 _ckvmssts_noperl(retsts); /* fall through */
10957 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10958 set_errno(EVMSERR);
10960 set_vaxc_errno(retsts);
10961 if (ckWARN(WARN_EXEC)) {
10962 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10963 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10965 vms_execfree(vmscmd);
10970 } /* end of vms_do_exec() */
10973 int do_spawn2(pTHX_ const char *, int);
10976 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10978 unsigned long int sts;
10984 /* We'll copy the (undocumented?) Win32 behavior and allow a
10985 * numeric first argument. But the only value we'll support
10986 * through do_aspawn is a value of 1, which means spawn without
10987 * waiting for completion -- other values are ignored.
10989 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10991 flags = SvIVx(*mark);
10994 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
10995 flags = CLI$M_NOWAIT;
10999 cmd = setup_argstr(aTHX_ really, mark, sp);
11000 sts = do_spawn2(aTHX_ cmd, flags);
11001 /* pp_sys will clean up cmd */
11005 } /* end of do_aspawn() */
11009 /* {{{int do_spawn(char* cmd) */
11011 Perl_do_spawn(pTHX_ char* cmd)
11013 PERL_ARGS_ASSERT_DO_SPAWN;
11015 return do_spawn2(aTHX_ cmd, 0);
11019 /* {{{int do_spawn_nowait(char* cmd) */
11021 Perl_do_spawn_nowait(pTHX_ char* cmd)
11023 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11025 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11029 /* {{{int do_spawn2(char *cmd) */
11031 do_spawn2(pTHX_ const char *cmd, int flags)
11033 unsigned long int sts, substs;
11035 /* The caller of this routine expects to Safefree(PL_Cmd) */
11036 Newx(PL_Cmd,10,char);
11039 TAINT_PROPER("spawn");
11040 if (!cmd || !*cmd) {
11041 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11044 case RMS$_FNF: case RMS$_DNF:
11045 set_errno(ENOENT); break;
11047 set_errno(ENOTDIR); break;
11049 set_errno(ENODEV); break;
11051 set_errno(EACCES); break;
11053 set_errno(EINVAL); break;
11054 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11055 set_errno(E2BIG); break;
11056 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11057 _ckvmssts_noperl(sts); /* fall through */
11058 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11059 set_errno(EVMSERR);
11061 set_vaxc_errno(sts);
11062 if (ckWARN(WARN_EXEC)) {
11063 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11072 if (flags & CLI$M_NOWAIT)
11075 strcpy(mode, "nW");
11077 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11080 /* sts will be the pid in the nowait case */
11083 } /* end of do_spawn2() */
11087 static unsigned int *sockflags, sockflagsize;
11090 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11091 * routines found in some versions of the CRTL can't deal with sockets.
11092 * We don't shim the other file open routines since a socket isn't
11093 * likely to be opened by a name.
11095 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11096 FILE *my_fdopen(int fd, const char *mode)
11098 FILE *fp = fdopen(fd, mode);
11101 unsigned int fdoff = fd / sizeof(unsigned int);
11102 Stat_t sbuf; /* native stat; we don't need flex_stat */
11103 if (!sockflagsize || fdoff > sockflagsize) {
11104 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
11105 else Newx (sockflags,fdoff+2,unsigned int);
11106 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11107 sockflagsize = fdoff + 2;
11109 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
11110 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11119 * Clear the corresponding bit when the (possibly) socket stream is closed.
11120 * There still a small hole: we miss an implicit close which might occur
11121 * via freopen(). >> Todo
11123 /*{{{ int my_fclose(FILE *fp)*/
11124 int my_fclose(FILE *fp) {
11126 unsigned int fd = fileno(fp);
11127 unsigned int fdoff = fd / sizeof(unsigned int);
11129 if (sockflagsize && fdoff < sockflagsize)
11130 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11138 * A simple fwrite replacement which outputs itmsz*nitm chars without
11139 * introducing record boundaries every itmsz chars.
11140 * We are using fputs, which depends on a terminating null. We may
11141 * well be writing binary data, so we need to accommodate not only
11142 * data with nulls sprinkled in the middle but also data with no null
11145 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11147 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11149 register char *cp, *end, *cpd, *data;
11150 register unsigned int fd = fileno(dest);
11151 register unsigned int fdoff = fd / sizeof(unsigned int);
11153 int bufsize = itmsz * nitm + 1;
11155 if (fdoff < sockflagsize &&
11156 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11157 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11161 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11162 memcpy( data, src, itmsz*nitm );
11163 data[itmsz*nitm] = '\0';
11165 end = data + itmsz * nitm;
11166 retval = (int) nitm; /* on success return # items written */
11169 while (cpd <= end) {
11170 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11171 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11173 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11177 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11180 } /* end of my_fwrite() */
11183 /*{{{ int my_flush(FILE *fp)*/
11185 Perl_my_flush(pTHX_ FILE *fp)
11188 if ((res = fflush(fp)) == 0 && fp) {
11189 #ifdef VMS_DO_SOCKETS
11191 if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11193 res = fsync(fileno(fp));
11196 * If the flush succeeded but set end-of-file, we need to clear
11197 * the error because our caller may check ferror(). BTW, this
11198 * probably means we just flushed an empty file.
11200 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11207 * Here are replacements for the following Unix routines in the VMS environment:
11208 * getpwuid Get information for a particular UIC or UID
11209 * getpwnam Get information for a named user
11210 * getpwent Get information for each user in the rights database
11211 * setpwent Reset search to the start of the rights database
11212 * endpwent Finish searching for users in the rights database
11214 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11215 * (defined in pwd.h), which contains the following fields:-
11217 * char *pw_name; Username (in lower case)
11218 * char *pw_passwd; Hashed password
11219 * unsigned int pw_uid; UIC
11220 * unsigned int pw_gid; UIC group number
11221 * char *pw_unixdir; Default device/directory (VMS-style)
11222 * char *pw_gecos; Owner name
11223 * char *pw_dir; Default device/directory (Unix-style)
11224 * char *pw_shell; Default CLI name (eg. DCL)
11226 * If the specified user does not exist, getpwuid and getpwnam return NULL.
11228 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11229 * not the UIC member number (eg. what's returned by getuid()),
11230 * getpwuid() can accept either as input (if uid is specified, the caller's
11231 * UIC group is used), though it won't recognise gid=0.
11233 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11234 * information about other users in your group or in other groups, respectively.
11235 * If the required privilege is not available, then these routines fill only
11236 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11239 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11242 /* sizes of various UAF record fields */
11243 #define UAI$S_USERNAME 12
11244 #define UAI$S_IDENT 31
11245 #define UAI$S_OWNER 31
11246 #define UAI$S_DEFDEV 31
11247 #define UAI$S_DEFDIR 63
11248 #define UAI$S_DEFCLI 31
11249 #define UAI$S_PWD 8
11251 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
11252 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11253 (uic).uic$v_group != UIC$K_WILD_GROUP)
11255 static char __empty[]= "";
11256 static struct passwd __passwd_empty=
11257 {(char *) __empty, (char *) __empty, 0, 0,
11258 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11259 static int contxt= 0;
11260 static struct passwd __pwdcache;
11261 static char __pw_namecache[UAI$S_IDENT+1];
11264 * This routine does most of the work extracting the user information.
11266 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11269 unsigned char length;
11270 char pw_gecos[UAI$S_OWNER+1];
11272 static union uicdef uic;
11274 unsigned char length;
11275 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11278 unsigned char length;
11279 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11282 unsigned char length;
11283 char pw_shell[UAI$S_DEFCLI+1];
11285 static char pw_passwd[UAI$S_PWD+1];
11287 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11288 struct dsc$descriptor_s name_desc;
11289 unsigned long int sts;
11291 static struct itmlst_3 itmlst[]= {
11292 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
11293 {sizeof(uic), UAI$_UIC, &uic, &luic},
11294 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
11295 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
11296 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
11297 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
11298 {0, 0, NULL, NULL}};
11300 name_desc.dsc$w_length= strlen(name);
11301 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11302 name_desc.dsc$b_class= DSC$K_CLASS_S;
11303 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11305 /* Note that sys$getuai returns many fields as counted strings. */
11306 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11307 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11308 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11310 else { _ckvmssts(sts); }
11311 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
11313 if ((int) owner.length < lowner) lowner= (int) owner.length;
11314 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11315 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11316 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11317 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11318 owner.pw_gecos[lowner]= '\0';
11319 defdev.pw_dir[ldefdev+ldefdir]= '\0';
11320 defcli.pw_shell[ldefcli]= '\0';
11321 if (valid_uic(uic)) {
11322 pwd->pw_uid= uic.uic$l_uic;
11323 pwd->pw_gid= uic.uic$v_group;
11326 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11327 pwd->pw_passwd= pw_passwd;
11328 pwd->pw_gecos= owner.pw_gecos;
11329 pwd->pw_dir= defdev.pw_dir;
11330 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11331 pwd->pw_shell= defcli.pw_shell;
11332 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11334 ldir= strlen(pwd->pw_unixdir) - 1;
11335 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11338 strcpy(pwd->pw_unixdir, pwd->pw_dir);
11339 if (!decc_efs_case_preserve)
11340 __mystrtolower(pwd->pw_unixdir);
11345 * Get information for a named user.
11347 /*{{{struct passwd *getpwnam(char *name)*/
11348 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11350 struct dsc$descriptor_s name_desc;
11352 unsigned long int status, sts;
11354 __pwdcache = __passwd_empty;
11355 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11356 /* We still may be able to determine pw_uid and pw_gid */
11357 name_desc.dsc$w_length= strlen(name);
11358 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11359 name_desc.dsc$b_class= DSC$K_CLASS_S;
11360 name_desc.dsc$a_pointer= (char *) name;
11361 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11362 __pwdcache.pw_uid= uic.uic$l_uic;
11363 __pwdcache.pw_gid= uic.uic$v_group;
11366 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11367 set_vaxc_errno(sts);
11368 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11371 else { _ckvmssts(sts); }
11374 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11375 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11376 __pwdcache.pw_name= __pw_namecache;
11377 return &__pwdcache;
11378 } /* end of my_getpwnam() */
11382 * Get information for a particular UIC or UID.
11383 * Called by my_getpwent with uid=-1 to list all users.
11385 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11386 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11388 const $DESCRIPTOR(name_desc,__pw_namecache);
11389 unsigned short lname;
11391 unsigned long int status;
11393 if (uid == (unsigned int) -1) {
11395 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11396 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11397 set_vaxc_errno(status);
11398 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11402 else { _ckvmssts(status); }
11403 } while (!valid_uic (uic));
11406 uic.uic$l_uic= uid;
11407 if (!uic.uic$v_group)
11408 uic.uic$v_group= PerlProc_getgid();
11409 if (valid_uic(uic))
11410 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11411 else status = SS$_IVIDENT;
11412 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11413 status == RMS$_PRV) {
11414 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11417 else { _ckvmssts(status); }
11419 __pw_namecache[lname]= '\0';
11420 __mystrtolower(__pw_namecache);
11422 __pwdcache = __passwd_empty;
11423 __pwdcache.pw_name = __pw_namecache;
11425 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11426 The identifier's value is usually the UIC, but it doesn't have to be,
11427 so if we can, we let fillpasswd update this. */
11428 __pwdcache.pw_uid = uic.uic$l_uic;
11429 __pwdcache.pw_gid = uic.uic$v_group;
11431 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11432 return &__pwdcache;
11434 } /* end of my_getpwuid() */
11438 * Get information for next user.
11440 /*{{{struct passwd *my_getpwent()*/
11441 struct passwd *Perl_my_getpwent(pTHX)
11443 return (my_getpwuid((unsigned int) -1));
11448 * Finish searching rights database for users.
11450 /*{{{void my_endpwent()*/
11451 void Perl_my_endpwent(pTHX)
11454 _ckvmssts(sys$finish_rdb(&contxt));
11460 #ifdef HOMEGROWN_POSIX_SIGNALS
11461 /* Signal handling routines, pulled into the core from POSIX.xs.
11463 * We need these for threads, so they've been rolled into the core,
11464 * rather than left in POSIX.xs.
11466 * (DRS, Oct 23, 1997)
11469 /* sigset_t is atomic under VMS, so these routines are easy */
11470 /*{{{int my_sigemptyset(sigset_t *) */
11471 int my_sigemptyset(sigset_t *set) {
11472 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11473 *set = 0; return 0;
11478 /*{{{int my_sigfillset(sigset_t *)*/
11479 int my_sigfillset(sigset_t *set) {
11481 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11482 for (i = 0; i < NSIG; i++) *set |= (1 << i);
11488 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11489 int my_sigaddset(sigset_t *set, int sig) {
11490 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11491 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11492 *set |= (1 << (sig - 1));
11498 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11499 int my_sigdelset(sigset_t *set, int sig) {
11500 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11501 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11502 *set &= ~(1 << (sig - 1));
11508 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11509 int my_sigismember(sigset_t *set, int sig) {
11510 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11511 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11512 return *set & (1 << (sig - 1));
11517 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11518 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11521 /* If set and oset are both null, then things are badly wrong. Bail out. */
11522 if ((oset == NULL) && (set == NULL)) {
11523 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11527 /* If set's null, then we're just handling a fetch. */
11529 tempmask = sigblock(0);
11534 tempmask = sigsetmask(*set);
11537 tempmask = sigblock(*set);
11540 tempmask = sigblock(0);
11541 sigsetmask(*oset & ~tempmask);
11544 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11549 /* Did they pass us an oset? If so, stick our holding mask into it */
11556 #endif /* HOMEGROWN_POSIX_SIGNALS */
11559 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11560 * my_utime(), and flex_stat(), all of which operate on UTC unless
11561 * VMSISH_TIMES is true.
11563 /* method used to handle UTC conversions:
11564 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
11566 static int gmtime_emulation_type;
11567 /* number of secs to add to UTC POSIX-style time to get local time */
11568 static long int utc_offset_secs;
11570 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11571 * in vmsish.h. #undef them here so we can call the CRTL routines
11580 * DEC C previous to 6.0 corrupts the behavior of the /prefix
11581 * qualifier with the extern prefix pragma. This provisional
11582 * hack circumvents this prefix pragma problem in previous
11585 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11586 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11587 # pragma __extern_prefix save
11588 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
11589 # define gmtime decc$__utctz_gmtime
11590 # define localtime decc$__utctz_localtime
11591 # define time decc$__utc_time
11592 # pragma __extern_prefix restore
11594 struct tm *gmtime(), *localtime();
11600 static time_t toutc_dst(time_t loc) {
11603 if ((rsltmp = localtime(&loc)) == NULL) return -1;
11604 loc -= utc_offset_secs;
11605 if (rsltmp->tm_isdst) loc -= 3600;
11608 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11609 ((gmtime_emulation_type || my_time(NULL)), \
11610 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11611 ((secs) - utc_offset_secs))))
11613 static time_t toloc_dst(time_t utc) {
11616 utc += utc_offset_secs;
11617 if ((rsltmp = localtime(&utc)) == NULL) return -1;
11618 if (rsltmp->tm_isdst) utc += 3600;
11621 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11622 ((gmtime_emulation_type || my_time(NULL)), \
11623 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11624 ((secs) + utc_offset_secs))))
11626 #ifndef RTL_USES_UTC
11629 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
11630 DST starts on 1st sun of april at 02:00 std time
11631 ends on last sun of october at 02:00 dst time
11632 see the UCX management command reference, SET CONFIG TIMEZONE
11633 for formatting info.
11635 No, it's not as general as it should be, but then again, NOTHING
11636 will handle UK times in a sensible way.
11641 parse the DST start/end info:
11642 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11646 tz_parse_startend(char *s, struct tm *w, int *past)
11648 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11649 int ly, dozjd, d, m, n, hour, min, sec, j, k;
11654 if (!past) return 0;
11657 if (w->tm_year % 4 == 0) ly = 1;
11658 if (w->tm_year % 100 == 0) ly = 0;
11659 if (w->tm_year+1900 % 400 == 0) ly = 1;
11662 dozjd = isdigit(*s);
11663 if (*s == 'J' || *s == 'j' || dozjd) {
11664 if (!dozjd && !isdigit(*++s)) return 0;
11667 d = d*10 + *s++ - '0';
11669 d = d*10 + *s++ - '0';
11672 if (d == 0) return 0;
11673 if (d > 366) return 0;
11675 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
11678 } else if (*s == 'M' || *s == 'm') {
11679 if (!isdigit(*++s)) return 0;
11681 if (isdigit(*s)) m = 10*m + *s++ - '0';
11682 if (*s != '.') return 0;
11683 if (!isdigit(*++s)) return 0;
11685 if (n < 1 || n > 5) return 0;
11686 if (*s != '.') return 0;
11687 if (!isdigit(*++s)) return 0;
11689 if (d > 6) return 0;
11693 if (!isdigit(*++s)) return 0;
11695 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11697 if (!isdigit(*++s)) return 0;
11699 if (isdigit(*s)) min = 10*min + *s++ - '0';
11701 if (!isdigit(*++s)) return 0;
11703 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11713 if (w->tm_yday < d) goto before;
11714 if (w->tm_yday > d) goto after;
11716 if (w->tm_mon+1 < m) goto before;
11717 if (w->tm_mon+1 > m) goto after;
11719 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
11720 k = d - j; /* mday of first d */
11721 if (k <= 0) k += 7;
11722 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
11723 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11724 if (w->tm_mday < k) goto before;
11725 if (w->tm_mday > k) goto after;
11728 if (w->tm_hour < hour) goto before;
11729 if (w->tm_hour > hour) goto after;
11730 if (w->tm_min < min) goto before;
11731 if (w->tm_min > min) goto after;
11732 if (w->tm_sec < sec) goto before;
11746 /* parse the offset: (+|-)hh[:mm[:ss]] */
11749 tz_parse_offset(char *s, int *offset)
11751 int hour = 0, min = 0, sec = 0;
11754 if (!offset) return 0;
11756 if (*s == '-') {neg++; s++;}
11757 if (*s == '+') s++;
11758 if (!isdigit(*s)) return 0;
11760 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11761 if (hour > 24) return 0;
11763 if (!isdigit(*++s)) return 0;
11765 if (isdigit(*s)) min = min*10 + (*s++ - '0');
11766 if (min > 59) return 0;
11768 if (!isdigit(*++s)) return 0;
11770 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11771 if (sec > 59) return 0;
11775 *offset = (hour*60+min)*60 + sec;
11776 if (neg) *offset = -*offset;
11781 input time is w, whatever type of time the CRTL localtime() uses.
11782 sets dst, the zone, and the gmtoff (seconds)
11784 caches the value of TZ and UCX$TZ env variables; note that
11785 my_setenv looks for these and sets a flag if they're changed
11788 We have to watch out for the "australian" case (dst starts in
11789 october, ends in april)...flagged by "reverse" and checked by
11790 scanning through the months of the previous year.
11795 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11800 char *dstzone, *tz, *s_start, *s_end;
11801 int std_off, dst_off, isdst;
11802 int y, dststart, dstend;
11803 static char envtz[1025]; /* longer than any logical, symbol, ... */
11804 static char ucxtz[1025];
11805 static char reversed = 0;
11811 reversed = -1; /* flag need to check */
11812 envtz[0] = ucxtz[0] = '\0';
11813 tz = my_getenv("TZ",0);
11814 if (tz) strcpy(envtz, tz);
11815 tz = my_getenv("UCX$TZ",0);
11816 if (tz) strcpy(ucxtz, tz);
11817 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
11820 if (!*tz) tz = ucxtz;
11823 while (isalpha(*s)) s++;
11824 s = tz_parse_offset(s, &std_off);
11826 if (!*s) { /* no DST, hurray we're done! */
11832 while (isalpha(*s)) s++;
11833 s2 = tz_parse_offset(s, &dst_off);
11837 dst_off = std_off - 3600;
11840 if (!*s) { /* default dst start/end?? */
11841 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
11842 s = strchr(ucxtz,',');
11844 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
11846 if (*s != ',') return 0;
11849 when = _toutc(when); /* convert to utc */
11850 when = when - std_off; /* convert to pseudolocal time*/
11852 w2 = localtime(&when);
11855 s = tz_parse_startend(s_start,w2,&dststart);
11857 if (*s != ',') return 0;
11860 when = _toutc(when); /* convert to utc */
11861 when = when - dst_off; /* convert to pseudolocal time*/
11862 w2 = localtime(&when);
11863 if (w2->tm_year != y) { /* spans a year, just check one time */
11864 when += dst_off - std_off;
11865 w2 = localtime(&when);
11868 s = tz_parse_startend(s_end,w2,&dstend);
11871 if (reversed == -1) { /* need to check if start later than end */
11875 if (when < 2*365*86400) {
11876 when += 2*365*86400;
11880 w2 =localtime(&when);
11881 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
11883 for (j = 0; j < 12; j++) {
11884 w2 =localtime(&when);
11885 tz_parse_startend(s_start,w2,&ds);
11886 tz_parse_startend(s_end,w2,&de);
11887 if (ds != de) break;
11891 if (de && !ds) reversed = 1;
11894 isdst = dststart && !dstend;
11895 if (reversed) isdst = dststart || !dstend;
11898 if (dst) *dst = isdst;
11899 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11900 if (isdst) tz = dstzone;
11902 while(isalpha(*tz)) *zone++ = *tz++;
11908 #endif /* !RTL_USES_UTC */
11910 /* my_time(), my_localtime(), my_gmtime()
11911 * By default traffic in UTC time values, using CRTL gmtime() or
11912 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11913 * Note: We need to use these functions even when the CRTL has working
11914 * UTC support, since they also handle C<use vmsish qw(times);>
11916 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
11917 * Modified by Charles Bailey <bailey@newman.upenn.edu>
11920 /*{{{time_t my_time(time_t *timep)*/
11921 time_t Perl_my_time(pTHX_ time_t *timep)
11926 if (gmtime_emulation_type == 0) {
11928 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11929 /* results of calls to gmtime() and localtime() */
11930 /* for same &base */
11932 gmtime_emulation_type++;
11933 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11934 char off[LNM$C_NAMLENGTH+1];;
11936 gmtime_emulation_type++;
11937 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11938 gmtime_emulation_type++;
11939 utc_offset_secs = 0;
11940 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11942 else { utc_offset_secs = atol(off); }
11944 else { /* We've got a working gmtime() */
11945 struct tm gmt, local;
11948 tm_p = localtime(&base);
11950 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11951 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11952 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11953 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11958 # ifdef VMSISH_TIME
11959 # ifdef RTL_USES_UTC
11960 if (VMSISH_TIME) when = _toloc(when);
11962 if (!VMSISH_TIME) when = _toutc(when);
11965 if (timep != NULL) *timep = when;
11968 } /* end of my_time() */
11972 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11974 Perl_my_gmtime(pTHX_ const time_t *timep)
11980 if (timep == NULL) {
11981 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11984 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11987 # ifdef VMSISH_TIME
11988 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11990 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
11991 return gmtime(&when);
11993 /* CRTL localtime() wants local time as input, so does no tz correction */
11994 rsltmp = localtime(&when);
11995 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
11998 } /* end of my_gmtime() */
12002 /*{{{struct tm *my_localtime(const time_t *timep)*/
12004 Perl_my_localtime(pTHX_ const time_t *timep)
12006 time_t when, whenutc;
12010 if (timep == NULL) {
12011 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12014 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
12015 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
12018 # ifdef RTL_USES_UTC
12019 # ifdef VMSISH_TIME
12020 if (VMSISH_TIME) when = _toutc(when);
12022 /* CRTL localtime() wants UTC as input, does tz correction itself */
12023 return localtime(&when);
12025 # else /* !RTL_USES_UTC */
12027 # ifdef VMSISH_TIME
12028 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
12029 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
12032 #ifndef RTL_USES_UTC
12033 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
12034 when = whenutc - offset; /* pseudolocal time*/
12037 /* CRTL localtime() wants local time as input, so does no tz correction */
12038 rsltmp = localtime(&when);
12039 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12043 } /* end of my_localtime() */
12046 /* Reset definitions for later calls */
12047 #define gmtime(t) my_gmtime(t)
12048 #define localtime(t) my_localtime(t)
12049 #define time(t) my_time(t)
12052 /* my_utime - update modification/access time of a file
12054 * VMS 7.3 and later implementation
12055 * Only the UTC translation is home-grown. The rest is handled by the
12056 * CRTL utime(), which will take into account the relevant feature
12057 * logicals and ODS-5 volume characteristics for true access times.
12059 * pre VMS 7.3 implementation:
12060 * The calling sequence is identical to POSIX utime(), but under
12061 * VMS with ODS-2, only the modification time is changed; ODS-2 does
12062 * not maintain access times. Restrictions differ from the POSIX
12063 * definition in that the time can be changed as long as the
12064 * caller has permission to execute the necessary IO$_MODIFY $QIO;
12065 * no separate checks are made to insure that the caller is the
12066 * owner of the file or has special privs enabled.
12067 * Code here is based on Joe Meadows' FILE utility.
12071 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12072 * to VMS epoch (01-JAN-1858 00:00:00.00)
12073 * in 100 ns intervals.
12075 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12077 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12078 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12080 #if __CRTL_VER >= 70300000
12081 struct utimbuf utc_utimes, *utc_utimesp;
12083 if (utimes != NULL) {
12084 utc_utimes.actime = utimes->actime;
12085 utc_utimes.modtime = utimes->modtime;
12086 # ifdef VMSISH_TIME
12087 /* If input was local; convert to UTC for sys svc */
12089 utc_utimes.actime = _toutc(utimes->actime);
12090 utc_utimes.modtime = _toutc(utimes->modtime);
12093 utc_utimesp = &utc_utimes;
12096 utc_utimesp = NULL;
12099 return utime(file, utc_utimesp);
12101 #else /* __CRTL_VER < 70300000 */
12105 long int bintime[2], len = 2, lowbit, unixtime,
12106 secscale = 10000000; /* seconds --> 100 ns intervals */
12107 unsigned long int chan, iosb[2], retsts;
12108 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12109 struct FAB myfab = cc$rms_fab;
12110 struct NAM mynam = cc$rms_nam;
12111 #if defined (__DECC) && defined (__VAX)
12112 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12113 * at least through VMS V6.1, which causes a type-conversion warning.
12115 # pragma message save
12116 # pragma message disable cvtdiftypes
12118 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12119 struct fibdef myfib;
12120 #if defined (__DECC) && defined (__VAX)
12121 /* This should be right after the declaration of myatr, but due
12122 * to a bug in VAX DEC C, this takes effect a statement early.
12124 # pragma message restore
12126 /* cast ok for read only parameter */
12127 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12128 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12129 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12131 if (file == NULL || *file == '\0') {
12132 SETERRNO(ENOENT, LIB$_INVARG);
12136 /* Convert to VMS format ensuring that it will fit in 255 characters */
12137 if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12138 SETERRNO(ENOENT, LIB$_INVARG);
12141 if (utimes != NULL) {
12142 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
12143 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12144 * Since time_t is unsigned long int, and lib$emul takes a signed long int
12145 * as input, we force the sign bit to be clear by shifting unixtime right
12146 * one bit, then multiplying by an extra factor of 2 in lib$emul().
12148 lowbit = (utimes->modtime & 1) ? secscale : 0;
12149 unixtime = (long int) utimes->modtime;
12150 # ifdef VMSISH_TIME
12151 /* If input was UTC; convert to local for sys svc */
12152 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12154 unixtime >>= 1; secscale <<= 1;
12155 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12156 if (!(retsts & 1)) {
12157 SETERRNO(EVMSERR, retsts);
12160 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12161 if (!(retsts & 1)) {
12162 SETERRNO(EVMSERR, retsts);
12167 /* Just get the current time in VMS format directly */
12168 retsts = sys$gettim(bintime);
12169 if (!(retsts & 1)) {
12170 SETERRNO(EVMSERR, retsts);
12175 myfab.fab$l_fna = vmsspec;
12176 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12177 myfab.fab$l_nam = &mynam;
12178 mynam.nam$l_esa = esa;
12179 mynam.nam$b_ess = (unsigned char) sizeof esa;
12180 mynam.nam$l_rsa = rsa;
12181 mynam.nam$b_rss = (unsigned char) sizeof rsa;
12182 if (decc_efs_case_preserve)
12183 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12185 /* Look for the file to be affected, letting RMS parse the file
12186 * specification for us as well. I have set errno using only
12187 * values documented in the utime() man page for VMS POSIX.
12189 retsts = sys$parse(&myfab,0,0);
12190 if (!(retsts & 1)) {
12191 set_vaxc_errno(retsts);
12192 if (retsts == RMS$_PRV) set_errno(EACCES);
12193 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12194 else set_errno(EVMSERR);
12197 retsts = sys$search(&myfab,0,0);
12198 if (!(retsts & 1)) {
12199 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12200 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12201 set_vaxc_errno(retsts);
12202 if (retsts == RMS$_PRV) set_errno(EACCES);
12203 else if (retsts == RMS$_FNF) set_errno(ENOENT);
12204 else set_errno(EVMSERR);
12208 devdsc.dsc$w_length = mynam.nam$b_dev;
12209 /* cast ok for read only parameter */
12210 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12212 retsts = sys$assign(&devdsc,&chan,0,0);
12213 if (!(retsts & 1)) {
12214 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12215 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12216 set_vaxc_errno(retsts);
12217 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
12218 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
12219 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
12220 else set_errno(EVMSERR);
12224 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12225 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12227 memset((void *) &myfib, 0, sizeof myfib);
12228 #if defined(__DECC) || defined(__DECCXX)
12229 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12230 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12231 /* This prevents the revision time of the file being reset to the current
12232 * time as a result of our IO$_MODIFY $QIO. */
12233 myfib.fib$l_acctl = FIB$M_NORECORD;
12235 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12236 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12237 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12239 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12240 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12241 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12242 _ckvmssts(sys$dassgn(chan));
12243 if (retsts & 1) retsts = iosb[0];
12244 if (!(retsts & 1)) {
12245 set_vaxc_errno(retsts);
12246 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12247 else set_errno(EVMSERR);
12253 #endif /* #if __CRTL_VER >= 70300000 */
12255 } /* end of my_utime() */
12259 * flex_stat, flex_lstat, flex_fstat
12260 * basic stat, but gets it right when asked to stat
12261 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12264 #ifndef _USE_STD_STAT
12265 /* encode_dev packs a VMS device name string into an integer to allow
12266 * simple comparisons. This can be used, for example, to check whether two
12267 * files are located on the same device, by comparing their encoded device
12268 * names. Even a string comparison would not do, because stat() reuses the
12269 * device name buffer for each call; so without encode_dev, it would be
12270 * necessary to save the buffer and use strcmp (this would mean a number of
12271 * changes to the standard Perl code, to say nothing of what a Perl script
12272 * would have to do.
12274 * The device lock id, if it exists, should be unique (unless perhaps compared
12275 * with lock ids transferred from other nodes). We have a lock id if the disk is
12276 * mounted cluster-wide, which is when we tend to get long (host-qualified)
12277 * device names. Thus we use the lock id in preference, and only if that isn't
12278 * available, do we try to pack the device name into an integer (flagged by
12279 * the sign bit (LOCKID_MASK) being set).
12281 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12282 * name and its encoded form, but it seems very unlikely that we will find
12283 * two files on different disks that share the same encoded device names,
12284 * and even more remote that they will share the same file id (if the test
12285 * is to check for the same file).
12287 * A better method might be to use sys$device_scan on the first call, and to
12288 * search for the device, returning an index into the cached array.
12289 * The number returned would be more intelligible.
12290 * This is probably not worth it, and anyway would take quite a bit longer
12291 * on the first call.
12293 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
12294 static mydev_t encode_dev (pTHX_ const char *dev)
12297 unsigned long int f;
12302 if (!dev || !dev[0]) return 0;
12306 struct dsc$descriptor_s dev_desc;
12307 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12309 /* For cluster-mounted disks, the disk lock identifier is unique, so we
12310 can try that first. */
12311 dev_desc.dsc$w_length = strlen (dev);
12312 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
12313 dev_desc.dsc$b_class = DSC$K_CLASS_S;
12314 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
12315 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12316 if (!$VMS_STATUS_SUCCESS(status)) {
12318 case SS$_NOSUCHDEV:
12319 SETERRNO(ENODEV, status);
12325 if (lockid) return (lockid & ~LOCKID_MASK);
12329 /* Otherwise we try to encode the device name */
12333 for (q = dev + strlen(dev); q--; q >= dev) {
12338 else if (isalpha (toupper (*q)))
12339 c= toupper (*q) - 'A' + (char)10;
12341 continue; /* Skip '$'s */
12343 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
12345 enc += f * (unsigned long int) c;
12347 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
12349 } /* end of encode_dev() */
12350 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12351 device_no = encode_dev(aTHX_ devname)
12353 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12354 device_no = new_dev_no
12358 is_null_device(name)
12361 if (decc_bug_devnull != 0) {
12362 if (strncmp("/dev/null", name, 9) == 0)
12365 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12366 The underscore prefix, controller letter, and unit number are
12367 independently optional; for our purposes, the colon punctuation
12368 is not. The colon can be trailed by optional directory and/or
12369 filename, but two consecutive colons indicates a nodename rather
12370 than a device. [pr] */
12371 if (*name == '_') ++name;
12372 if (tolower(*name++) != 'n') return 0;
12373 if (tolower(*name++) != 'l') return 0;
12374 if (tolower(*name) == 'a') ++name;
12375 if (*name == '0') ++name;
12376 return (*name++ == ':') && (*name != ':');
12381 Perl_cando_by_name_int
12382 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12384 char usrname[L_cuserid];
12385 struct dsc$descriptor_s usrdsc =
12386 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12387 char *vmsname = NULL, *fileified = NULL;
12388 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12389 unsigned short int retlen, trnlnm_iter_count;
12390 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12391 union prvdef curprv;
12392 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12393 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12394 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12395 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12396 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12398 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12400 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12402 static int profile_context = -1;
12404 if (!fname || !*fname) return FALSE;
12406 /* Make sure we expand logical names, since sys$check_access doesn't */
12407 fileified = PerlMem_malloc(VMS_MAXRSS);
12408 if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12409 if (!strpbrk(fname,"/]>:")) {
12410 strcpy(fileified,fname);
12411 trnlnm_iter_count = 0;
12412 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12413 trnlnm_iter_count++;
12414 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12419 vmsname = PerlMem_malloc(VMS_MAXRSS);
12420 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12421 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12422 /* Don't know if already in VMS format, so make sure */
12423 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12424 PerlMem_free(fileified);
12425 PerlMem_free(vmsname);
12430 strcpy(vmsname,fname);
12433 /* sys$check_access needs a file spec, not a directory spec.
12434 * Don't use flex_stat here, as that depends on thread context
12435 * having been initialized, and we may get here during startup.
12438 retlen = namdsc.dsc$w_length = strlen(vmsname);
12439 if (vmsname[retlen-1] == ']'
12440 || vmsname[retlen-1] == '>'
12441 || vmsname[retlen-1] == ':'
12442 || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
12444 if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12445 PerlMem_free(fileified);
12446 PerlMem_free(vmsname);
12455 retlen = namdsc.dsc$w_length = strlen(fname);
12456 namdsc.dsc$a_pointer = (char *)fname;
12459 case S_IXUSR: case S_IXGRP: case S_IXOTH:
12460 access = ARM$M_EXECUTE;
12461 flags = CHP$M_READ;
12463 case S_IRUSR: case S_IRGRP: case S_IROTH:
12464 access = ARM$M_READ;
12465 flags = CHP$M_READ | CHP$M_USEREADALL;
12467 case S_IWUSR: case S_IWGRP: case S_IWOTH:
12468 access = ARM$M_WRITE;
12469 flags = CHP$M_READ | CHP$M_WRITE;
12471 case S_IDUSR: case S_IDGRP: case S_IDOTH:
12472 access = ARM$M_DELETE;
12473 flags = CHP$M_READ | CHP$M_WRITE;
12476 if (fileified != NULL)
12477 PerlMem_free(fileified);
12478 if (vmsname != NULL)
12479 PerlMem_free(vmsname);
12483 /* Before we call $check_access, create a user profile with the current
12484 * process privs since otherwise it just uses the default privs from the
12485 * UAF and might give false positives or negatives. This only works on
12486 * VMS versions v6.0 and later since that's when sys$create_user_profile
12487 * became available.
12490 /* get current process privs and username */
12491 _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12492 _ckvmssts_noperl(iosb[0]);
12494 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12496 /* find out the space required for the profile */
12497 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12498 &usrprodsc.dsc$w_length,&profile_context));
12500 /* allocate space for the profile and get it filled in */
12501 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12502 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12503 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12504 &usrprodsc.dsc$w_length,&profile_context));
12506 /* use the profile to check access to the file; free profile & analyze results */
12507 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12508 PerlMem_free(usrprodsc.dsc$a_pointer);
12509 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12513 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12517 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
12518 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12519 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12520 set_vaxc_errno(retsts);
12521 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12522 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12523 else set_errno(ENOENT);
12524 if (fileified != NULL)
12525 PerlMem_free(fileified);
12526 if (vmsname != NULL)
12527 PerlMem_free(vmsname);
12530 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12531 if (fileified != NULL)
12532 PerlMem_free(fileified);
12533 if (vmsname != NULL)
12534 PerlMem_free(vmsname);
12537 _ckvmssts_noperl(retsts);
12539 if (fileified != NULL)
12540 PerlMem_free(fileified);
12541 if (vmsname != NULL)
12542 PerlMem_free(vmsname);
12543 return FALSE; /* Should never get here */
12547 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
12548 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12549 * subset of the applicable information.
12552 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12554 return cando_by_name_int
12555 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12556 } /* end of cando() */
12560 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12562 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12564 return cando_by_name_int(bit, effective, fname, 0);
12566 } /* end of cando_by_name() */
12570 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12572 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12574 if (!fstat(fd,(stat_t *) statbufp)) {
12576 char *vms_filename;
12577 vms_filename = PerlMem_malloc(VMS_MAXRSS);
12578 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12580 /* Save name for cando by name in VMS format */
12581 cptr = getname(fd, vms_filename, 1);
12583 /* This should not happen, but just in case */
12584 if (cptr == NULL) {
12585 statbufp->st_devnam[0] = 0;
12588 /* Make sure that the saved name fits in 255 characters */
12589 cptr = int_rmsexpand_vms
12591 statbufp->st_devnam,
12594 statbufp->st_devnam[0] = 0;
12596 PerlMem_free(vms_filename);
12598 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12600 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12602 # ifdef RTL_USES_UTC
12603 # ifdef VMSISH_TIME
12605 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12606 statbufp->st_atime = _toloc(statbufp->st_atime);
12607 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12611 # ifdef VMSISH_TIME
12612 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12616 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12617 statbufp->st_atime = _toutc(statbufp->st_atime);
12618 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12625 } /* end of flex_fstat() */
12628 #if !defined(__VAX) && __CRTL_VER >= 80200000
12636 #define lstat(_x, _y) stat(_x, _y)
12639 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
12642 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12644 char fileified[VMS_MAXRSS];
12645 char temp_fspec[VMS_MAXRSS];
12650 if (!fspec) return retval;
12652 strcpy(temp_fspec, fspec);
12654 if (decc_bug_devnull != 0) {
12655 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
12656 memset(statbufp,0,sizeof *statbufp);
12657 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12658 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12659 statbufp->st_uid = 0x00010001;
12660 statbufp->st_gid = 0x0001;
12661 time((time_t *)&statbufp->st_mtime);
12662 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12667 /* Try for a directory name first. If fspec contains a filename without
12668 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12669 * and sea:[wine.dark]water. exist, we prefer the directory here.
12670 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12671 * not sea:[wine.dark]., if the latter exists. If the intended target is
12672 * the file with null type, specify this by calling flex_stat() with
12673 * a '.' at the end of fspec.
12675 * If we are in Posix filespec mode, accept the filename as is.
12679 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12680 /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
12681 * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
12683 if (!decc_efs_charset)
12684 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
12687 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12688 if (decc_posix_compliant_pathnames == 0) {
12690 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
12691 if (lstat_flag == 0)
12692 retval = stat(fileified,(stat_t *) statbufp);
12694 retval = lstat(fileified,(stat_t *) statbufp);
12695 save_spec = fileified;
12698 if (lstat_flag == 0)
12699 retval = stat(temp_fspec,(stat_t *) statbufp);
12701 retval = lstat(temp_fspec,(stat_t *) statbufp);
12702 save_spec = temp_fspec;
12705 * In debugging, on 8.3 Alpha, I found a case where stat was returning a
12706 * file not found error for a directory named foo:[bar.t] or /foo/bar/t
12707 * and lstat was working correctly for the same file.
12708 * The only syntax that was working for stat was "foo:[bar]t.dir".
12710 * Other directories with the same syntax worked fine.
12711 * So work around the problem when it shows up here.
12714 int save_errno = errno;
12715 if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
12716 if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
12717 retval = stat(fileified, (stat_t *) statbufp);
12718 save_spec = fileified;
12721 /* Restore the errno value if third stat does not succeed */
12723 errno = save_errno;
12725 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12727 if (lstat_flag == 0)
12728 retval = stat(temp_fspec,(stat_t *) statbufp);
12730 retval = lstat(temp_fspec,(stat_t *) statbufp);
12731 save_spec = temp_fspec;
12735 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12736 /* As you were... */
12737 if (!decc_efs_charset)
12738 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12743 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12745 /* If this is an lstat, do not follow the link */
12747 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12749 cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12751 statbufp->st_devnam[0] = 0;
12753 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12755 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12756 # ifdef RTL_USES_UTC
12757 # ifdef VMSISH_TIME
12759 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12760 statbufp->st_atime = _toloc(statbufp->st_atime);
12761 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12765 # ifdef VMSISH_TIME
12766 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12770 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12771 statbufp->st_atime = _toutc(statbufp->st_atime);
12772 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12776 /* If we were successful, leave errno where we found it */
12777 if (retval == 0) RESTORE_ERRNO;
12780 } /* end of flex_stat_int() */
12783 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12785 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12787 return flex_stat_int(fspec, statbufp, 0);
12791 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12793 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12795 return flex_stat_int(fspec, statbufp, 1);
12800 /*{{{char *my_getlogin()*/
12801 /* VMS cuserid == Unix getlogin, except calling sequence */
12805 static char user[L_cuserid];
12806 return cuserid(user);
12811 /* rmscopy - copy a file using VMS RMS routines
12813 * Copies contents and attributes of spec_in to spec_out, except owner
12814 * and protection information. Name and type of spec_in are used as
12815 * defaults for spec_out. The third parameter specifies whether rmscopy()
12816 * should try to propagate timestamps from the input file to the output file.
12817 * If it is less than 0, no timestamps are preserved. If it is 0, then
12818 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12819 * propagated to the output file at creation iff the output file specification
12820 * did not contain an explicit name or type, and the revision date is always
12821 * updated at the end of the copy operation. If it is greater than 0, then
12822 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12823 * other than the revision date should be propagated, and bit 1 indicates
12824 * that the revision date should be propagated.
12826 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12828 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12829 * Incorporates, with permission, some code from EZCOPY by Tim Adye
12830 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12831 * as part of the Perl standard distribution under the terms of the
12832 * GNU General Public License or the Perl Artistic License. Copies
12833 * of each may be found in the Perl standard distribution.
12835 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12837 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12839 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12840 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12841 unsigned long int i, sts, sts2;
12843 struct FAB fab_in, fab_out;
12844 struct RAB rab_in, rab_out;
12845 rms_setup_nam(nam);
12846 rms_setup_nam(nam_out);
12847 struct XABDAT xabdat;
12848 struct XABFHC xabfhc;
12849 struct XABRDT xabrdt;
12850 struct XABSUM xabsum;
12852 vmsin = PerlMem_malloc(VMS_MAXRSS);
12853 if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12854 vmsout = PerlMem_malloc(VMS_MAXRSS);
12855 if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12856 if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12857 !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12858 PerlMem_free(vmsin);
12859 PerlMem_free(vmsout);
12860 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12864 esa = PerlMem_malloc(VMS_MAXRSS);
12865 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12867 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12868 esal = PerlMem_malloc(VMS_MAXRSS);
12869 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12871 fab_in = cc$rms_fab;
12872 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12873 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12874 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12875 fab_in.fab$l_fop = FAB$M_SQO;
12876 rms_bind_fab_nam(fab_in, nam);
12877 fab_in.fab$l_xab = (void *) &xabdat;
12879 rsa = PerlMem_malloc(VMS_MAXRSS);
12880 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12882 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12883 rsal = PerlMem_malloc(VMS_MAXRSS);
12884 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12886 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12887 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12888 rms_nam_esl(nam) = 0;
12889 rms_nam_rsl(nam) = 0;
12890 rms_nam_esll(nam) = 0;
12891 rms_nam_rsll(nam) = 0;
12892 #ifdef NAM$M_NO_SHORT_UPCASE
12893 if (decc_efs_case_preserve)
12894 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12897 xabdat = cc$rms_xabdat; /* To get creation date */
12898 xabdat.xab$l_nxt = (void *) &xabfhc;
12900 xabfhc = cc$rms_xabfhc; /* To get record length */
12901 xabfhc.xab$l_nxt = (void *) &xabsum;
12903 xabsum = cc$rms_xabsum; /* To get key and area information */
12905 if (!((sts = sys$open(&fab_in)) & 1)) {
12906 PerlMem_free(vmsin);
12907 PerlMem_free(vmsout);
12910 PerlMem_free(esal);
12913 PerlMem_free(rsal);
12914 set_vaxc_errno(sts);
12916 case RMS$_FNF: case RMS$_DNF:
12917 set_errno(ENOENT); break;
12919 set_errno(ENOTDIR); break;
12921 set_errno(ENODEV); break;
12923 set_errno(EINVAL); break;
12925 set_errno(EACCES); break;
12927 set_errno(EVMSERR);
12934 fab_out.fab$w_ifi = 0;
12935 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12936 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12937 fab_out.fab$l_fop = FAB$M_SQO;
12938 rms_bind_fab_nam(fab_out, nam_out);
12939 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12940 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12941 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12942 esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12943 if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12944 rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12945 if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12948 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12949 esal_out = PerlMem_malloc(VMS_MAXRSS);
12950 if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12951 rsal_out = PerlMem_malloc(VMS_MAXRSS);
12952 if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12954 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12955 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12957 if (preserve_dates == 0) { /* Act like DCL COPY */
12958 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12959 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
12960 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12961 PerlMem_free(vmsin);
12962 PerlMem_free(vmsout);
12965 PerlMem_free(esal);
12968 PerlMem_free(rsal);
12969 PerlMem_free(esa_out);
12970 if (esal_out != NULL)
12971 PerlMem_free(esal_out);
12972 PerlMem_free(rsa_out);
12973 if (rsal_out != NULL)
12974 PerlMem_free(rsal_out);
12975 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12976 set_vaxc_errno(sts);
12979 fab_out.fab$l_xab = (void *) &xabdat;
12980 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12981 preserve_dates = 1;
12983 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12984 preserve_dates =0; /* bitmask from this point forward */
12986 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12987 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12988 PerlMem_free(vmsin);
12989 PerlMem_free(vmsout);
12992 PerlMem_free(esal);
12995 PerlMem_free(rsal);
12996 PerlMem_free(esa_out);
12997 if (esal_out != NULL)
12998 PerlMem_free(esal_out);
12999 PerlMem_free(rsa_out);
13000 if (rsal_out != NULL)
13001 PerlMem_free(rsal_out);
13002 set_vaxc_errno(sts);
13005 set_errno(ENOENT); break;
13007 set_errno(ENOTDIR); break;
13009 set_errno(ENODEV); break;
13011 set_errno(EINVAL); break;
13013 set_errno(EACCES); break;
13015 set_errno(EVMSERR);
13019 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
13020 if (preserve_dates & 2) {
13021 /* sys$close() will process xabrdt, not xabdat */
13022 xabrdt = cc$rms_xabrdt;
13024 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
13026 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
13027 * is unsigned long[2], while DECC & VAXC use a struct */
13028 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
13030 fab_out.fab$l_xab = (void *) &xabrdt;
13033 ubf = PerlMem_malloc(32256);
13034 if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13035 rab_in = cc$rms_rab;
13036 rab_in.rab$l_fab = &fab_in;
13037 rab_in.rab$l_rop = RAB$M_BIO;
13038 rab_in.rab$l_ubf = ubf;
13039 rab_in.rab$w_usz = 32256;
13040 if (!((sts = sys$connect(&rab_in)) & 1)) {
13041 sys$close(&fab_in); sys$close(&fab_out);
13042 PerlMem_free(vmsin);
13043 PerlMem_free(vmsout);
13047 PerlMem_free(esal);
13050 PerlMem_free(rsal);
13051 PerlMem_free(esa_out);
13052 if (esal_out != NULL)
13053 PerlMem_free(esal_out);
13054 PerlMem_free(rsa_out);
13055 if (rsal_out != NULL)
13056 PerlMem_free(rsal_out);
13057 set_errno(EVMSERR); set_vaxc_errno(sts);
13061 rab_out = cc$rms_rab;
13062 rab_out.rab$l_fab = &fab_out;
13063 rab_out.rab$l_rbf = ubf;
13064 if (!((sts = sys$connect(&rab_out)) & 1)) {
13065 sys$close(&fab_in); sys$close(&fab_out);
13066 PerlMem_free(vmsin);
13067 PerlMem_free(vmsout);
13071 PerlMem_free(esal);
13074 PerlMem_free(rsal);
13075 PerlMem_free(esa_out);
13076 if (esal_out != NULL)
13077 PerlMem_free(esal_out);
13078 PerlMem_free(rsa_out);
13079 if (rsal_out != NULL)
13080 PerlMem_free(rsal_out);
13081 set_errno(EVMSERR); set_vaxc_errno(sts);
13085 while ((sts = sys$read(&rab_in))) { /* always true */
13086 if (sts == RMS$_EOF) break;
13087 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13088 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13089 sys$close(&fab_in); sys$close(&fab_out);
13090 PerlMem_free(vmsin);
13091 PerlMem_free(vmsout);
13095 PerlMem_free(esal);
13098 PerlMem_free(rsal);
13099 PerlMem_free(esa_out);
13100 if (esal_out != NULL)
13101 PerlMem_free(esal_out);
13102 PerlMem_free(rsa_out);
13103 if (rsal_out != NULL)
13104 PerlMem_free(rsal_out);
13105 set_errno(EVMSERR); set_vaxc_errno(sts);
13111 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
13112 sys$close(&fab_in); sys$close(&fab_out);
13113 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13115 PerlMem_free(vmsin);
13116 PerlMem_free(vmsout);
13120 PerlMem_free(esal);
13123 PerlMem_free(rsal);
13124 PerlMem_free(esa_out);
13125 if (esal_out != NULL)
13126 PerlMem_free(esal_out);
13127 PerlMem_free(rsa_out);
13128 if (rsal_out != NULL)
13129 PerlMem_free(rsal_out);
13132 set_errno(EVMSERR); set_vaxc_errno(sts);
13138 } /* end of rmscopy() */
13142 /*** The following glue provides 'hooks' to make some of the routines
13143 * from this file available from Perl. These routines are sufficiently
13144 * basic, and are required sufficiently early in the build process,
13145 * that's it's nice to have them available to miniperl as well as the
13146 * full Perl, so they're set up here instead of in an extension. The
13147 * Perl code which handles importation of these names into a given
13148 * package lives in [.VMS]Filespec.pm in @INC.
13152 rmsexpand_fromperl(pTHX_ CV *cv)
13155 char *fspec, *defspec = NULL, *rslt;
13157 int fs_utf8, dfs_utf8;
13161 if (!items || items > 2)
13162 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13163 fspec = SvPV(ST(0),n_a);
13164 fs_utf8 = SvUTF8(ST(0));
13165 if (!fspec || !*fspec) XSRETURN_UNDEF;
13167 defspec = SvPV(ST(1),n_a);
13168 dfs_utf8 = SvUTF8(ST(1));
13170 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13171 ST(0) = sv_newmortal();
13172 if (rslt != NULL) {
13173 sv_usepvn(ST(0),rslt,strlen(rslt));
13182 vmsify_fromperl(pTHX_ CV *cv)
13189 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13190 utf8_fl = SvUTF8(ST(0));
13191 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13192 ST(0) = sv_newmortal();
13193 if (vmsified != NULL) {
13194 sv_usepvn(ST(0),vmsified,strlen(vmsified));
13203 unixify_fromperl(pTHX_ CV *cv)
13210 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13211 utf8_fl = SvUTF8(ST(0));
13212 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13213 ST(0) = sv_newmortal();
13214 if (unixified != NULL) {
13215 sv_usepvn(ST(0),unixified,strlen(unixified));
13224 fileify_fromperl(pTHX_ CV *cv)
13231 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13232 utf8_fl = SvUTF8(ST(0));
13233 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13234 ST(0) = sv_newmortal();
13235 if (fileified != NULL) {
13236 sv_usepvn(ST(0),fileified,strlen(fileified));
13245 pathify_fromperl(pTHX_ CV *cv)
13252 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13253 utf8_fl = SvUTF8(ST(0));
13254 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13255 ST(0) = sv_newmortal();
13256 if (pathified != NULL) {
13257 sv_usepvn(ST(0),pathified,strlen(pathified));
13266 vmspath_fromperl(pTHX_ CV *cv)
13273 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13274 utf8_fl = SvUTF8(ST(0));
13275 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13276 ST(0) = sv_newmortal();
13277 if (vmspath != NULL) {
13278 sv_usepvn(ST(0),vmspath,strlen(vmspath));
13287 unixpath_fromperl(pTHX_ CV *cv)
13294 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13295 utf8_fl = SvUTF8(ST(0));
13296 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13297 ST(0) = sv_newmortal();
13298 if (unixpath != NULL) {
13299 sv_usepvn(ST(0),unixpath,strlen(unixpath));
13308 candelete_fromperl(pTHX_ CV *cv)
13316 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13318 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13319 Newx(fspec, VMS_MAXRSS, char);
13320 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13321 if (SvTYPE(mysv) == SVt_PVGV) {
13322 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13323 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13331 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13332 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13339 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13345 rmscopy_fromperl(pTHX_ CV *cv)
13348 char *inspec, *outspec, *inp, *outp;
13350 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13351 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13352 unsigned long int sts;
13357 if (items < 2 || items > 3)
13358 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13360 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13361 Newx(inspec, VMS_MAXRSS, char);
13362 if (SvTYPE(mysv) == SVt_PVGV) {
13363 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13364 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13372 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13373 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13379 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13380 Newx(outspec, VMS_MAXRSS, char);
13381 if (SvTYPE(mysv) == SVt_PVGV) {
13382 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13383 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13392 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13393 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13400 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13402 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
13408 /* The mod2fname is limited to shorter filenames by design, so it should
13409 * not be modified to support longer EFS pathnames
13412 mod2fname(pTHX_ CV *cv)
13415 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13416 workbuff[NAM$C_MAXRSS*1 + 1];
13417 int total_namelen = 3, counter, num_entries;
13418 /* ODS-5 ups this, but we want to be consistent, so... */
13419 int max_name_len = 39;
13420 AV *in_array = (AV *)SvRV(ST(0));
13422 num_entries = av_len(in_array);
13424 /* All the names start with PL_. */
13425 strcpy(ultimate_name, "PL_");
13427 /* Clean up our working buffer */
13428 Zero(work_name, sizeof(work_name), char);
13430 /* Run through the entries and build up a working name */
13431 for(counter = 0; counter <= num_entries; counter++) {
13432 /* If it's not the first name then tack on a __ */
13434 strcat(work_name, "__");
13436 strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13439 /* Check to see if we actually have to bother...*/
13440 if (strlen(work_name) + 3 <= max_name_len) {
13441 strcat(ultimate_name, work_name);
13443 /* It's too darned big, so we need to go strip. We use the same */
13444 /* algorithm as xsubpp does. First, strip out doubled __ */
13445 char *source, *dest, last;
13448 for (source = work_name; *source; source++) {
13449 if (last == *source && last == '_') {
13455 /* Go put it back */
13456 strcpy(work_name, workbuff);
13457 /* Is it still too big? */
13458 if (strlen(work_name) + 3 > max_name_len) {
13459 /* Strip duplicate letters */
13462 for (source = work_name; *source; source++) {
13463 if (last == toupper(*source)) {
13467 last = toupper(*source);
13469 strcpy(work_name, workbuff);
13472 /* Is it *still* too big? */
13473 if (strlen(work_name) + 3 > max_name_len) {
13474 /* Too bad, we truncate */
13475 work_name[max_name_len - 2] = 0;
13477 strcat(ultimate_name, work_name);
13480 /* Okay, return it */
13481 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13486 hushexit_fromperl(pTHX_ CV *cv)
13491 VMSISH_HUSHED = SvTRUE(ST(0));
13493 ST(0) = boolSV(VMSISH_HUSHED);
13499 Perl_vms_start_glob
13500 (pTHX_ SV *tmpglob,
13504 struct vs_str_st *rslt;
13508 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13511 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13512 struct dsc$descriptor_vs rsdsc;
13513 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13514 unsigned long hasver = 0, isunix = 0;
13515 unsigned long int lff_flags = 0;
13517 int vms_old_glob = 1;
13519 if (!SvOK(tmpglob)) {
13520 SETERRNO(ENOENT,RMS$_FNF);
13524 vms_old_glob = !decc_filename_unix_report;
13526 #ifdef VMS_LONGNAME_SUPPORT
13527 lff_flags = LIB$M_FIL_LONG_NAMES;
13529 /* The Newx macro will not allow me to assign a smaller array
13530 * to the rslt pointer, so we will assign it to the begin char pointer
13531 * and then copy the value into the rslt pointer.
13533 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13534 rslt = (struct vs_str_st *)begin;
13536 rstr = &rslt->str[0];
13537 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13538 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13539 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13540 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13542 Newx(vmsspec, VMS_MAXRSS, char);
13544 /* We could find out if there's an explicit dev/dir or version
13545 by peeking into lib$find_file's internal context at
13546 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13547 but that's unsupported, so I don't want to do it now and
13548 have it bite someone in the future. */
13549 /* Fix-me: vms_split_path() is the only way to do this, the
13550 existing method will fail with many legal EFS or UNIX specifications
13553 cp = SvPV(tmpglob,i);
13556 if (cp[i] == ';') hasver = 1;
13557 if (cp[i] == '.') {
13558 if (sts) hasver = 1;
13561 if (cp[i] == '/') {
13562 hasdir = isunix = 1;
13565 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13571 /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13572 if ((hasdir == 0) && decc_filename_unix_report) {
13576 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13577 char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13578 int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13584 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13585 if (!stat_sts && S_ISDIR(st.st_mode)) {
13587 const char * fname;
13590 /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13591 /* path delimiter of ':>]', if so, then the old behavior has */
13592 /* obviously been specificially requested */
13594 fname = SvPVX_const(tmpglob);
13595 fname_len = strlen(fname);
13596 vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13597 if (vms_old_glob || (vms_dir != NULL)) {
13598 wilddsc.dsc$a_pointer = tovmspath_utf8(
13599 SvPVX(tmpglob),vmsspec,NULL);
13600 ok = (wilddsc.dsc$a_pointer != NULL);
13601 /* maybe passed 'foo' rather than '[.foo]', thus not
13605 /* Operate just on the directory, the special stat/fstat for */
13606 /* leaves the fileified specification in the st_devnam */
13608 wilddsc.dsc$a_pointer = st.st_devnam;
13613 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13614 ok = (wilddsc.dsc$a_pointer != NULL);
13617 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13619 /* If not extended character set, replace ? with % */
13620 /* With extended character set, ? is a wildcard single character */
13621 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13624 if (!decc_efs_case_preserve)
13626 } else if (*cp == '%') {
13628 } else if (*cp == '*') {
13634 wv_sts = vms_split_path(
13635 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13636 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13637 &wvs_spec, &wvs_len);
13646 while (ok && $VMS_STATUS_SUCCESS(sts)) {
13647 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13648 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13652 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13653 &dfltdsc,NULL,&rms_sts,&lff_flags);
13654 if (!$VMS_STATUS_SUCCESS(sts))
13657 /* with varying string, 1st word of buffer contains result length */
13658 rstr[rslt->length] = '\0';
13660 /* Find where all the components are */
13661 v_sts = vms_split_path
13676 /* If no version on input, truncate the version on output */
13677 if (!hasver && (vs_len > 0)) {
13684 /* In Unix report mode, remove the ".dir;1" from the name */
13685 /* if it is a real directory */
13686 if (decc_filename_unix_report || decc_efs_charset) {
13687 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13691 ret_sts = flex_lstat(rstr, &statbuf);
13692 if ((ret_sts == 0) &&
13693 S_ISDIR(statbuf.st_mode)) {
13700 /* No version & a null extension on UNIX handling */
13701 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13707 if (!decc_efs_case_preserve) {
13708 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13711 /* Find File treats a Null extension as return all extensions */
13712 /* This is contrary to Perl expectations */
13714 if (wildstar || wildquery || vms_old_glob) {
13715 /* really need to see if the returned file name matched */
13716 /* but for now will assume that it matches */
13719 /* Exact Match requested */
13720 /* How are directories handled? - like a file */
13721 if ((e_len == we_len) && (n_len == wn_len)) {
13725 t1 = strncmp(e_spec, we_spec, e_len);
13729 t1 = strncmp(n_spec, we_spec, n_len);
13740 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13744 /* Start with the name */
13747 strcat(begin,"\n");
13748 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13751 if (cxt) (void)lib$find_file_end(&cxt);
13754 /* Be POSIXish: return the input pattern when no matches */
13755 strcpy(rstr,SvPVX(tmpglob));
13757 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13760 if (ok && sts != RMS$_NMF &&
13761 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13764 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13766 PerlIO_close(tmpfp);
13770 PerlIO_rewind(tmpfp);
13771 IoTYPE(io) = IoTYPE_RDONLY;
13772 IoIFP(io) = fp = tmpfp;
13773 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
13783 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13787 unixrealpath_fromperl(pTHX_ CV *cv)
13790 char *fspec, *rslt_spec, *rslt;
13793 if (!items || items != 1)
13794 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13796 fspec = SvPV(ST(0),n_a);
13797 if (!fspec || !*fspec) XSRETURN_UNDEF;
13799 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13800 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13802 ST(0) = sv_newmortal();
13804 sv_usepvn(ST(0),rslt,strlen(rslt));
13806 Safefree(rslt_spec);
13811 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13815 vmsrealpath_fromperl(pTHX_ CV *cv)
13818 char *fspec, *rslt_spec, *rslt;
13821 if (!items || items != 1)
13822 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13824 fspec = SvPV(ST(0),n_a);
13825 if (!fspec || !*fspec) XSRETURN_UNDEF;
13827 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13828 rslt = do_vms_realname(fspec, rslt_spec, NULL);
13830 ST(0) = sv_newmortal();
13832 sv_usepvn(ST(0),rslt,strlen(rslt));
13834 Safefree(rslt_spec);
13840 * A thin wrapper around decc$symlink to make sure we follow the
13841 * standard and do not create a symlink with a zero-length name.
13843 * Also in ODS-2 mode, existing tests assume that the link target
13844 * will be converted to UNIX format.
13846 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13847 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13848 if (!link_name || !*link_name) {
13849 SETERRNO(ENOENT, SS$_NOSUCHFILE);
13853 if (decc_efs_charset) {
13854 return symlink(contents, link_name);
13859 /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13860 /* because in order to work, the symlink target must be in UNIX format */
13862 /* As symbolic links can hold things other than files, we will only do */
13863 /* the conversion in in ODS-2 mode */
13865 Newx(utarget, VMS_MAXRSS + 1, char);
13866 if (int_tounixspec(contents, utarget, NULL) == NULL) {
13868 /* This should not fail, as an untranslatable filename */
13869 /* should be passed through */
13870 utarget = (char *)contents;
13872 sts = symlink(utarget, link_name);
13880 #endif /* HAS_SYMLINK */
13882 int do_vms_case_tolerant(void);
13885 case_tolerant_process_fromperl(pTHX_ CV *cv)
13888 ST(0) = boolSV(do_vms_case_tolerant());
13892 #ifdef USE_ITHREADS
13895 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13896 struct interp_intern *dst)
13898 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13900 memcpy(dst,src,sizeof(struct interp_intern));
13906 Perl_sys_intern_clear(pTHX)
13911 Perl_sys_intern_init(pTHX)
13913 unsigned int ix = RAND_MAX;
13918 MY_POSIX_EXIT = vms_posix_exit;
13921 MY_INV_RAND_MAX = 1./x;
13925 init_os_extras(void)
13928 char* file = __FILE__;
13929 if (decc_disable_to_vms_logname_translation) {
13930 no_translate_barewords = TRUE;
13932 no_translate_barewords = FALSE;
13935 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13936 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13937 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13938 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13939 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13940 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13941 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13942 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13943 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13944 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13945 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13946 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13947 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13948 newXSproto("VMS::Filespec::case_tolerant_process",
13949 case_tolerant_process_fromperl,file,"");
13951 store_pipelocs(aTHX); /* will redo any earlier attempts */
13956 #if __CRTL_VER == 80200000
13957 /* This missed getting in to the DECC SDK for 8.2 */
13958 char *realpath(const char *file_name, char * resolved_name, ...);
13961 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13962 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13963 * The perl fallback routine to provide realpath() is not as efficient
13967 /* Hack, use old stat() as fastest way of getting ino_t and device */
13968 int decc$stat(const char *name, void * statbuf);
13971 /* Realpath is fragile. In 8.3 it does not work if the feature
13972 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13973 * links are implemented in RMS, not the CRTL. It also can fail if the
13974 * user does not have read/execute access to some of the directories.
13975 * So in order for Do What I Mean mode to work, if realpath() fails,
13976 * fall back to looking up the filename by the device name and FID.
13979 int vms_fid_to_name(char * outname, int outlen, const char * name)
13983 unsigned short st_ino[3];
13984 unsigned short padw;
13985 unsigned long padl[30]; /* plenty of room */
13988 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13989 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13991 sts = decc$stat(name, &statbuf);
13994 dvidsc.dsc$a_pointer=statbuf.st_dev;
13995 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13997 specdsc.dsc$a_pointer = outname;
13998 specdsc.dsc$w_length = outlen-1;
14000 sts = lib$fid_to_name
14001 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
14002 if ($VMS_STATUS_SUCCESS(sts)) {
14003 outname[specdsc.dsc$w_length] = 0;
14013 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
14016 char * rslt = NULL;
14019 if (decc_posix_compliant_pathnames > 0 ) {
14020 /* realpath currently only works if posix compliant pathnames are
14021 * enabled. It may start working when they are not, but in that
14022 * case we still want the fallback behavior for backwards compatibility
14024 rslt = realpath(filespec, outbuf);
14028 if (rslt == NULL) {
14030 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14031 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14034 /* Fall back to fid_to_name */
14036 Newx(vms_spec, VMS_MAXRSS + 1, char);
14038 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
14042 /* Now need to trim the version off */
14043 sts = vms_split_path
14063 /* Trim off the version */
14064 int file_len = v_len + r_len + d_len + n_len + e_len;
14065 vms_spec[file_len] = 0;
14067 /* The result is expected to be in UNIX format */
14068 rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14070 /* Downcase if input had any lower case letters and
14071 * case preservation is not in effect.
14073 if (!decc_efs_case_preserve) {
14074 for (cp = filespec; *cp; cp++)
14075 if (islower(*cp)) { haslower = 1; break; }
14077 if (haslower) __mystrtolower(rslt);
14082 /* Now for some hacks to deal with backwards and forward */
14084 if (!decc_efs_charset) {
14086 /* 1. ODS-2 mode wants to do a syntax only translation */
14087 rslt = int_rmsexpand(filespec, outbuf,
14088 NULL, 0, NULL, utf8_fl);
14091 if (decc_filename_unix_report) {
14093 char * vms_dir_name;
14096 /* 2. ODS-5 / UNIX report mode should return a failure */
14097 /* if the parent directory also does not exist */
14098 /* Otherwise, get the real path for the parent */
14099 /* and add the child to it.
14101 /* basename / dirname only available for VMS 7.0+ */
14102 /* So we may need to implement them as common routines */
14104 Newx(dir_name, VMS_MAXRSS + 1, char);
14105 Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14106 dir_name[0] = '\0';
14109 /* First try a VMS parse */
14110 sts = vms_split_path
14128 int dir_len = v_len + r_len + d_len + n_len;
14130 strncpy(dir_name, filespec, dir_len);
14131 dir_name[dir_len] = '\0';
14132 file_name = (char *)&filespec[dir_len + 1];
14135 /* This must be UNIX */
14138 tchar = strrchr(filespec, '/');
14140 if (tchar != NULL) {
14141 int dir_len = tchar - filespec;
14142 strncpy(dir_name, filespec, dir_len);
14143 dir_name[dir_len] = '\0';
14144 file_name = (char *) &filespec[dir_len + 1];
14148 /* Dir name is defaulted */
14149 if (dir_name[0] == 0) {
14151 dir_name[1] = '\0';
14154 /* Need realpath for the directory */
14155 sts = vms_fid_to_name(vms_dir_name,
14160 /* Now need to pathify it.
14161 char *tdir = int_pathify_dirspec(vms_dir_name,
14164 /* And now add the original filespec to it */
14165 if (file_name != NULL) {
14166 strcat(outbuf, file_name);
14170 Safefree(vms_dir_name);
14171 Safefree(dir_name);
14175 Safefree(vms_spec);
14181 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14184 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14185 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14188 /* Fall back to fid_to_name */
14190 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
14197 /* Now need to trim the version off */
14198 sts = vms_split_path
14218 /* Trim off the version */
14219 int file_len = v_len + r_len + d_len + n_len + e_len;
14220 outbuf[file_len] = 0;
14222 /* Downcase if input had any lower case letters and
14223 * case preservation is not in effect.
14225 if (!decc_efs_case_preserve) {
14226 for (cp = filespec; *cp; cp++)
14227 if (islower(*cp)) { haslower = 1; break; }
14229 if (haslower) __mystrtolower(outbuf);
14238 /* External entry points */
14239 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14240 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14242 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14243 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14245 /* case_tolerant */
14247 /*{{{int do_vms_case_tolerant(void)*/
14248 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14249 * controlled by a process setting.
14251 int do_vms_case_tolerant(void)
14253 return vms_process_case_tolerant;
14256 /* External entry points */
14257 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14258 int Perl_vms_case_tolerant(void)
14259 { return do_vms_case_tolerant(); }
14261 int Perl_vms_case_tolerant(void)
14262 { return vms_process_case_tolerant; }
14266 /* Start of DECC RTL Feature handling */
14268 static int sys_trnlnm
14269 (const char * logname,
14273 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14274 const unsigned long attr = LNM$M_CASE_BLIND;
14275 struct dsc$descriptor_s name_dsc;
14277 unsigned short result;
14278 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14281 name_dsc.dsc$w_length = strlen(logname);
14282 name_dsc.dsc$a_pointer = (char *)logname;
14283 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14284 name_dsc.dsc$b_class = DSC$K_CLASS_S;
14286 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14288 if ($VMS_STATUS_SUCCESS(status)) {
14290 /* Null terminate and return the string */
14291 /*--------------------------------------*/
14298 static int sys_crelnm
14299 (const char * logname,
14300 const char * value)
14303 const char * proc_table = "LNM$PROCESS_TABLE";
14304 struct dsc$descriptor_s proc_table_dsc;
14305 struct dsc$descriptor_s logname_dsc;
14306 struct itmlst_3 item_list[2];
14308 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14309 proc_table_dsc.dsc$w_length = strlen(proc_table);
14310 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14311 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14313 logname_dsc.dsc$a_pointer = (char *) logname;
14314 logname_dsc.dsc$w_length = strlen(logname);
14315 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14316 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14318 item_list[0].buflen = strlen(value);
14319 item_list[0].itmcode = LNM$_STRING;
14320 item_list[0].bufadr = (char *)value;
14321 item_list[0].retlen = NULL;
14323 item_list[1].buflen = 0;
14324 item_list[1].itmcode = 0;
14326 ret_val = sys$crelnm
14328 (const struct dsc$descriptor_s *)&proc_table_dsc,
14329 (const struct dsc$descriptor_s *)&logname_dsc,
14331 (const struct item_list_3 *) item_list);
14336 /* C RTL Feature settings */
14338 static int set_features
14339 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
14340 int (* cli_routine)(void), /* Not documented */
14341 void *image_info) /* Not documented */
14347 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14348 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14349 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14350 unsigned long case_perm;
14351 unsigned long case_image;
14354 /* Allow an exception to bring Perl into the VMS debugger */
14355 vms_debug_on_exception = 0;
14356 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14357 if ($VMS_STATUS_SUCCESS(status)) {
14358 val_str[0] = _toupper(val_str[0]);
14359 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14360 vms_debug_on_exception = 1;
14362 vms_debug_on_exception = 0;
14365 /* Debug unix/vms file translation routines */
14366 vms_debug_fileify = 0;
14367 status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14368 if ($VMS_STATUS_SUCCESS(status)) {
14369 val_str[0] = _toupper(val_str[0]);
14370 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14371 vms_debug_fileify = 1;
14373 vms_debug_fileify = 0;
14377 /* Historically PERL has been doing vmsify / stat differently than */
14378 /* the CRTL. In particular, under some conditions the CRTL will */
14379 /* remove some illegal characters like spaces from filenames */
14380 /* resulting in some differences. The stat()/lstat() wrapper has */
14381 /* been reporting such file names as invalid and fails to stat them */
14382 /* fixing this bug so that stat()/lstat() accept these like the */
14383 /* CRTL does will result in several tests failing. */
14384 /* This should really be fixed, but for now, set up a feature to */
14385 /* enable it so that the impact can be studied. */
14386 vms_bug_stat_filename = 0;
14387 status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14388 if ($VMS_STATUS_SUCCESS(status)) {
14389 val_str[0] = _toupper(val_str[0]);
14390 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14391 vms_bug_stat_filename = 1;
14393 vms_bug_stat_filename = 0;
14397 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14398 vms_vtf7_filenames = 0;
14399 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14400 if ($VMS_STATUS_SUCCESS(status)) {
14401 val_str[0] = _toupper(val_str[0]);
14402 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14403 vms_vtf7_filenames = 1;
14405 vms_vtf7_filenames = 0;
14408 /* unlink all versions on unlink() or rename() */
14409 vms_unlink_all_versions = 0;
14410 status = sys_trnlnm
14411 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14412 if ($VMS_STATUS_SUCCESS(status)) {
14413 val_str[0] = _toupper(val_str[0]);
14414 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14415 vms_unlink_all_versions = 1;
14417 vms_unlink_all_versions = 0;
14420 /* Dectect running under GNV Bash or other UNIX like shell */
14421 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14422 gnv_unix_shell = 0;
14423 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14424 if ($VMS_STATUS_SUCCESS(status)) {
14425 gnv_unix_shell = 1;
14426 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14427 set_feature_default("DECC$EFS_CHARSET", 1);
14428 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14429 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14430 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14431 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14432 vms_unlink_all_versions = 1;
14433 vms_posix_exit = 1;
14437 /* hacks to see if known bugs are still present for testing */
14439 /* PCP mode requires creating /dev/null special device file */
14440 decc_bug_devnull = 0;
14441 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14442 if ($VMS_STATUS_SUCCESS(status)) {
14443 val_str[0] = _toupper(val_str[0]);
14444 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14445 decc_bug_devnull = 1;
14447 decc_bug_devnull = 0;
14450 /* UNIX directory names with no paths are broken in a lot of places */
14451 decc_dir_barename = 1;
14452 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14453 if ($VMS_STATUS_SUCCESS(status)) {
14454 val_str[0] = _toupper(val_str[0]);
14455 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14456 decc_dir_barename = 1;
14458 decc_dir_barename = 0;
14461 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14462 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14464 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14465 if (decc_disable_to_vms_logname_translation < 0)
14466 decc_disable_to_vms_logname_translation = 0;
14469 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14471 decc_efs_case_preserve = decc$feature_get_value(s, 1);
14472 if (decc_efs_case_preserve < 0)
14473 decc_efs_case_preserve = 0;
14476 s = decc$feature_get_index("DECC$EFS_CHARSET");
14477 decc_efs_charset_index = s;
14479 decc_efs_charset = decc$feature_get_value(s, 1);
14480 if (decc_efs_charset < 0)
14481 decc_efs_charset = 0;
14484 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14486 decc_filename_unix_report = decc$feature_get_value(s, 1);
14487 if (decc_filename_unix_report > 0) {
14488 decc_filename_unix_report = 1;
14489 vms_posix_exit = 1;
14492 decc_filename_unix_report = 0;
14495 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14497 decc_filename_unix_only = decc$feature_get_value(s, 1);
14498 if (decc_filename_unix_only > 0) {
14499 decc_filename_unix_only = 1;
14502 decc_filename_unix_only = 0;
14506 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14508 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14509 if (decc_filename_unix_no_version < 0)
14510 decc_filename_unix_no_version = 0;
14513 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14515 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14516 if (decc_readdir_dropdotnotype < 0)
14517 decc_readdir_dropdotnotype = 0;
14520 #if __CRTL_VER >= 80200000
14521 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14523 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14524 if (decc_posix_compliant_pathnames < 0)
14525 decc_posix_compliant_pathnames = 0;
14526 if (decc_posix_compliant_pathnames > 4)
14527 decc_posix_compliant_pathnames = 0;
14532 status = sys_trnlnm
14533 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14534 if ($VMS_STATUS_SUCCESS(status)) {
14535 val_str[0] = _toupper(val_str[0]);
14536 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14537 decc_disable_to_vms_logname_translation = 1;
14542 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14543 if ($VMS_STATUS_SUCCESS(status)) {
14544 val_str[0] = _toupper(val_str[0]);
14545 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14546 decc_efs_case_preserve = 1;
14551 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14552 if ($VMS_STATUS_SUCCESS(status)) {
14553 val_str[0] = _toupper(val_str[0]);
14554 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14555 decc_filename_unix_report = 1;
14558 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14559 if ($VMS_STATUS_SUCCESS(status)) {
14560 val_str[0] = _toupper(val_str[0]);
14561 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14562 decc_filename_unix_only = 1;
14563 decc_filename_unix_report = 1;
14566 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14567 if ($VMS_STATUS_SUCCESS(status)) {
14568 val_str[0] = _toupper(val_str[0]);
14569 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14570 decc_filename_unix_no_version = 1;
14573 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14574 if ($VMS_STATUS_SUCCESS(status)) {
14575 val_str[0] = _toupper(val_str[0]);
14576 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14577 decc_readdir_dropdotnotype = 1;
14582 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14584 /* Report true case tolerance */
14585 /*----------------------------*/
14586 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14587 if (!$VMS_STATUS_SUCCESS(status))
14588 case_perm = PPROP$K_CASE_BLIND;
14589 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14590 if (!$VMS_STATUS_SUCCESS(status))
14591 case_image = PPROP$K_CASE_BLIND;
14592 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14593 (case_image == PPROP$K_CASE_SENSITIVE))
14594 vms_process_case_tolerant = 0;
14598 /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
14599 /* for strict backward compatibilty */
14600 status = sys_trnlnm
14601 ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14602 if ($VMS_STATUS_SUCCESS(status)) {
14603 val_str[0] = _toupper(val_str[0]);
14604 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14605 vms_posix_exit = 1;
14607 vms_posix_exit = 0;
14611 /* CRTL can be initialized past this point, but not before. */
14612 /* DECC$CRTL_INIT(); */
14619 #pragma extern_model save
14620 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14621 const __align (LONGWORD) int spare[8] = {0};
14623 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14624 #if __DECC_VER >= 60560002
14625 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14627 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14629 #endif /* __DECC */
14631 const long vms_cc_features = (const long)set_features;
14634 ** Force a reference to LIB$INITIALIZE to ensure it
14635 ** exists in the image.
14637 int lib$initialize(void);
14639 #pragma extern_model strict_refdef
14641 int lib_init_ref = (int) lib$initialize;
14644 #pragma extern_model restore