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_]
29 #if __CRTL_VER < 70300000
30 /* needed for home-rolled utime() */
36 #include <climsgdef.h>
46 #include <libclidef.h>
48 #include <lib$routines.h>
51 #if __CRTL_VER >= 70301000 && !defined(__VAX)
61 #include <str$routines.h>
67 #define NO_EFN EFN$C_ENF
69 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
70 int decc$feature_get_index(const char *name);
71 char* decc$feature_get_name(int index);
72 int decc$feature_get_value(int index, int mode);
73 int decc$feature_set_value(int index, int mode, int value);
78 #pragma member_alignment save
79 #pragma nomember_alignment longword
84 unsigned short * retadr;
86 #pragma member_alignment restore
88 #if __CRTL_VER >= 70300000 && !defined(__VAX)
90 static int set_feature_default(const char *name, int value)
95 index = decc$feature_get_index(name);
97 status = decc$feature_set_value(index, 1, value);
98 if (index == -1 || (status == -1)) {
102 status = decc$feature_get_value(index, 1);
103 if (status != value) {
111 /* Older versions of ssdef.h don't have these */
112 #ifndef SS$_INVFILFOROP
113 # define SS$_INVFILFOROP 3930
115 #ifndef SS$_NOSUCHOBJECT
116 # define SS$_NOSUCHOBJECT 2696
119 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
120 #define PERLIO_NOT_STDIO 0
122 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
123 * code below needs to get to the underlying CRTL routines. */
124 #define DONT_MASK_RTL_CALLS
128 /* Anticipating future expansion in lexical warnings . . . */
129 #ifndef WARN_INTERNAL
130 # define WARN_INTERNAL WARN_MISC
133 #ifdef VMS_LONGNAME_SUPPORT
134 #include <libfildef.h>
137 #if !defined(__VAX) && __CRTL_VER >= 80200000
145 #define lstat(_x, _y) stat(_x, _y)
148 /* Routine to create a decterm for use with the Perl debugger */
149 /* No headers, this information was found in the Programming Concepts Manual */
151 static int (*decw_term_port)
152 (const struct dsc$descriptor_s * display,
153 const struct dsc$descriptor_s * setup_file,
154 const struct dsc$descriptor_s * customization,
155 struct dsc$descriptor_s * result_device_name,
156 unsigned short * result_device_name_length,
159 void * char_change_buffer) = 0;
161 /* gcc's header files don't #define direct access macros
162 * corresponding to VAXC's variant structs */
164 # define uic$v_format uic$r_uic_form.uic$v_format
165 # define uic$v_group uic$r_uic_form.uic$v_group
166 # define uic$v_member uic$r_uic_form.uic$v_member
167 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
168 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
169 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
170 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
173 #if defined(NEED_AN_H_ERRNO)
177 #if defined(__DECC) || defined(__DECCXX)
178 #pragma member_alignment save
179 #pragma nomember_alignment longword
181 #pragma message disable misalgndmem
184 unsigned short int buflen;
185 unsigned short int itmcode;
187 unsigned short int *retlen;
190 struct filescan_itmlst_2 {
191 unsigned short length;
192 unsigned short itmcode;
197 unsigned short length;
198 char str[VMS_MAXRSS];
199 unsigned short pad; /* for longword struct alignment */
202 #if defined(__DECC) || defined(__DECCXX)
203 #pragma message restore
204 #pragma member_alignment restore
207 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
208 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
209 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
210 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
211 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
212 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
213 #define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
214 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
215 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
216 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
217 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
218 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
220 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
221 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
222 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
223 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
225 static char * int_rmsexpand_vms(
226 const char * filespec, char * outbuf, unsigned opts);
227 static char * int_rmsexpand_tovms(
228 const char * filespec, char * outbuf, unsigned opts);
229 static char *int_tovmsspec
230 (const char *path, char *buf, int dir_flag, int * utf8_flag);
231 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
232 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
233 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
235 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
236 #define PERL_LNM_MAX_ALLOWED_INDEX 127
238 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
239 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
242 #define PERL_LNM_MAX_ITER 10
244 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
245 #if __CRTL_VER >= 70302000 && !defined(__VAX)
246 #define MAX_DCL_SYMBOL (8192)
247 #define MAX_DCL_LINE_LENGTH (4096 - 4)
249 #define MAX_DCL_SYMBOL (1024)
250 #define MAX_DCL_LINE_LENGTH (1024 - 4)
253 static char *__mystrtolower(char *str)
255 if (str) for (; *str; ++str) *str= tolower(*str);
259 static struct dsc$descriptor_s fildevdsc =
260 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
261 static struct dsc$descriptor_s crtlenvdsc =
262 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
263 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
264 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
265 static struct dsc$descriptor_s **env_tables = defenv;
266 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
268 /* True if we shouldn't treat barewords as logicals during directory */
270 static int no_translate_barewords;
272 /* DECC Features that may need to affect how Perl interprets
273 * displays filename information
275 static int decc_disable_to_vms_logname_translation = 1;
276 static int decc_disable_posix_root = 1;
277 int decc_efs_case_preserve = 0;
278 static int decc_efs_charset = 0;
279 static int decc_efs_charset_index = -1;
280 static int decc_filename_unix_no_version = 0;
281 static int decc_filename_unix_only = 0;
282 int decc_filename_unix_report = 0;
283 int decc_posix_compliant_pathnames = 0;
284 int decc_readdir_dropdotnotype = 0;
285 static int vms_process_case_tolerant = 1;
286 int vms_vtf7_filenames = 0;
287 int gnv_unix_shell = 0;
288 static int vms_unlink_all_versions = 0;
289 static int vms_posix_exit = 0;
291 /* bug workarounds if needed */
292 int decc_bug_devnull = 1;
293 int decc_dir_barename = 0;
294 int vms_bug_stat_filename = 0;
296 static int vms_debug_on_exception = 0;
297 static int vms_debug_fileify = 0;
299 /* Simple logical name translation */
300 static int simple_trnlnm
301 (const char * logname,
305 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
306 const unsigned long attr = LNM$M_CASE_BLIND;
307 struct dsc$descriptor_s name_dsc;
309 unsigned short result;
310 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
313 name_dsc.dsc$w_length = strlen(logname);
314 name_dsc.dsc$a_pointer = (char *)logname;
315 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
316 name_dsc.dsc$b_class = DSC$K_CLASS_S;
318 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
320 if ($VMS_STATUS_SUCCESS(status)) {
322 /* Null terminate and return the string */
323 /*--------------------------------------*/
332 /* Is this a UNIX file specification?
333 * No longer a simple check with EFS file specs
334 * For now, not a full check, but need to
335 * handle POSIX ^UP^ specifications
336 * Fixing to handle ^/ cases would require
337 * changes to many other conversion routines.
340 static int is_unix_filespec(const char *path)
346 if (strncmp(path,"\"^UP^",5) != 0) {
347 pch1 = strchr(path, '/');
352 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
353 if (decc_filename_unix_report || decc_filename_unix_only) {
354 if (strcmp(path,".") == 0)
362 /* This routine converts a UCS-2 character to be VTF-7 encoded.
365 static void ucs2_to_vtf7
367 unsigned long ucs2_char,
370 unsigned char * ucs_ptr;
373 ucs_ptr = (unsigned char *)&ucs2_char;
377 hex = (ucs_ptr[1] >> 4) & 0xf;
379 outspec[2] = hex + '0';
381 outspec[2] = (hex - 9) + 'A';
382 hex = ucs_ptr[1] & 0xF;
384 outspec[3] = hex + '0';
386 outspec[3] = (hex - 9) + 'A';
388 hex = (ucs_ptr[0] >> 4) & 0xf;
390 outspec[4] = hex + '0';
392 outspec[4] = (hex - 9) + 'A';
393 hex = ucs_ptr[1] & 0xF;
395 outspec[5] = hex + '0';
397 outspec[5] = (hex - 9) + 'A';
403 /* This handles the conversion of a UNIX extended character set to a ^
404 * escaped VMS character.
405 * in a UNIX file specification.
407 * The output count variable contains the number of characters added
408 * to the output string.
410 * The return value is the number of characters read from the input string
412 static int copy_expand_unix_filename_escape
413 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
420 utf8_flag = *utf8_fl;
424 if (*inspec >= 0x80) {
425 if (utf8_fl && vms_vtf7_filenames) {
426 unsigned long ucs_char;
430 if ((*inspec & 0xE0) == 0xC0) {
432 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
433 if (ucs_char >= 0x80) {
434 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
437 } else if ((*inspec & 0xF0) == 0xE0) {
439 ucs_char = ((inspec[0] & 0xF) << 12) +
440 ((inspec[1] & 0x3f) << 6) +
442 if (ucs_char >= 0x800) {
443 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
447 #if 0 /* I do not see longer sequences supported by OpenVMS */
448 /* Maybe some one can fix this later */
449 } else if ((*inspec & 0xF8) == 0xF0) {
452 } else if ((*inspec & 0xFC) == 0xF8) {
455 } else if ((*inspec & 0xFE) == 0xFC) {
462 /* High bit set, but not a Unicode character! */
464 /* Non printing DECMCS or ISO Latin-1 character? */
465 if ((unsigned char)*inspec <= 0x9F) {
469 hex = (*inspec >> 4) & 0xF;
471 outspec[1] = hex + '0';
473 outspec[1] = (hex - 9) + 'A';
477 outspec[2] = hex + '0';
479 outspec[2] = (hex - 9) + 'A';
483 } else if ((unsigned char)*inspec == 0xA0) {
489 } else if ((unsigned char)*inspec == 0xFF) {
501 /* Is this a macro that needs to be passed through?
502 * Macros start with $( and an alpha character, followed
503 * by a string of alpha numeric characters ending with a )
504 * If this does not match, then encode it as ODS-5.
506 if ((inspec[0] == '$') && (inspec[1] == '(')) {
509 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
511 outspec[0] = inspec[0];
512 outspec[1] = inspec[1];
513 outspec[2] = inspec[2];
515 while(isalnum(inspec[tcnt]) ||
516 (inspec[2] == '.') || (inspec[2] == '_')) {
517 outspec[tcnt] = inspec[tcnt];
520 if (inspec[tcnt] == ')') {
521 outspec[tcnt] = inspec[tcnt];
538 if (decc_efs_charset == 0)
565 /* Don't escape again if following character is
566 * already something we escape.
568 if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
574 /* But otherwise fall through and escape it. */
576 /* Assume that this is to be escaped */
578 outspec[1] = *inspec;
582 case ' ': /* space */
583 /* Assume that this is to be escaped */
599 /* This handles the expansion of a '^' prefix to the proper character
600 * in a UNIX file specification.
602 * The output count variable contains the number of characters added
603 * to the output string.
605 * The return value is the number of characters read from the input
608 static int copy_expand_vms_filename_escape
609 (char *outspec, const char *inspec, int *output_cnt)
616 if (*inspec == '^') {
619 /* Spaces and non-trailing dots should just be passed through,
620 * but eat the escape character.
627 case '_': /* space */
633 /* Hmm. Better leave the escape escaped. */
639 case 'U': /* Unicode - FIX-ME this is wrong. */
642 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
645 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
646 outspec[0] = c1 & 0xff;
647 outspec[1] = c2 & 0xff;
654 /* Error - do best we can to continue */
664 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
668 scnt = sscanf(inspec, "%2x", &c1);
669 outspec[0] = c1 & 0xff;
690 /* vms_split_path - Verify that the input file specification is a
691 * VMS format file specification, and provide pointers to the components of
692 * it. With EFS format filenames, this is virtually the only way to
693 * parse a VMS path specification into components.
695 * If the sum of the components do not add up to the length of the
696 * string, then the passed file specification is probably a UNIX style
699 static int vms_split_path
714 struct dsc$descriptor path_desc;
718 struct filescan_itmlst_2 item_list[9];
719 const int filespec = 0;
720 const int nodespec = 1;
721 const int devspec = 2;
722 const int rootspec = 3;
723 const int dirspec = 4;
724 const int namespec = 5;
725 const int typespec = 6;
726 const int verspec = 7;
728 /* Assume the worst for an easy exit */
742 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
743 path_desc.dsc$w_length = strlen(path);
744 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
745 path_desc.dsc$b_class = DSC$K_CLASS_S;
747 /* Get the total length, if it is shorter than the string passed
748 * then this was probably not a VMS formatted file specification
750 item_list[filespec].itmcode = FSCN$_FILESPEC;
751 item_list[filespec].length = 0;
752 item_list[filespec].component = NULL;
754 /* If the node is present, then it gets considered as part of the
755 * volume name to hopefully make things simple.
757 item_list[nodespec].itmcode = FSCN$_NODE;
758 item_list[nodespec].length = 0;
759 item_list[nodespec].component = NULL;
761 item_list[devspec].itmcode = FSCN$_DEVICE;
762 item_list[devspec].length = 0;
763 item_list[devspec].component = NULL;
765 /* root is a special case, adding it to either the directory or
766 * the device components will probably complicate things for the
767 * callers of this routine, so leave it separate.
769 item_list[rootspec].itmcode = FSCN$_ROOT;
770 item_list[rootspec].length = 0;
771 item_list[rootspec].component = NULL;
773 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
774 item_list[dirspec].length = 0;
775 item_list[dirspec].component = NULL;
777 item_list[namespec].itmcode = FSCN$_NAME;
778 item_list[namespec].length = 0;
779 item_list[namespec].component = NULL;
781 item_list[typespec].itmcode = FSCN$_TYPE;
782 item_list[typespec].length = 0;
783 item_list[typespec].component = NULL;
785 item_list[verspec].itmcode = FSCN$_VERSION;
786 item_list[verspec].length = 0;
787 item_list[verspec].component = NULL;
789 item_list[8].itmcode = 0;
790 item_list[8].length = 0;
791 item_list[8].component = NULL;
793 status = sys$filescan
794 ((const struct dsc$descriptor_s *)&path_desc, item_list,
796 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
798 /* If we parsed it successfully these two lengths should be the same */
799 if (path_desc.dsc$w_length != item_list[filespec].length)
802 /* If we got here, then it is a VMS file specification */
805 /* set the volume name */
806 if (item_list[nodespec].length > 0) {
807 *volume = item_list[nodespec].component;
808 *vol_len = item_list[nodespec].length + item_list[devspec].length;
811 *volume = item_list[devspec].component;
812 *vol_len = item_list[devspec].length;
815 *root = item_list[rootspec].component;
816 *root_len = item_list[rootspec].length;
818 *dir = item_list[dirspec].component;
819 *dir_len = item_list[dirspec].length;
821 /* Now fun with versions and EFS file specifications
822 * The parser can not tell the difference when a "." is a version
823 * delimiter or a part of the file specification.
825 if ((decc_efs_charset) &&
826 (item_list[verspec].length > 0) &&
827 (item_list[verspec].component[0] == '.')) {
828 *name = item_list[namespec].component;
829 *name_len = item_list[namespec].length + item_list[typespec].length;
830 *ext = item_list[verspec].component;
831 *ext_len = item_list[verspec].length;
836 *name = item_list[namespec].component;
837 *name_len = item_list[namespec].length;
838 *ext = item_list[typespec].component;
839 *ext_len = item_list[typespec].length;
840 *version = item_list[verspec].component;
841 *ver_len = item_list[verspec].length;
846 /* Routine to determine if the file specification ends with .dir */
847 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
849 /* e_len must be 4, and version must be <= 2 characters */
850 if (e_len != 4 || vs_len > 2)
853 /* If a version number is present, it needs to be one */
854 if ((vs_len == 2) && (vs_spec[1] != '1'))
857 /* Look for the DIR on the extension */
858 if (vms_process_case_tolerant) {
859 if ((toupper(e_spec[1]) == 'D') &&
860 (toupper(e_spec[2]) == 'I') &&
861 (toupper(e_spec[3]) == 'R')) {
865 /* Directory extensions are supposed to be in upper case only */
866 /* I would not be surprised if this rule can not be enforced */
867 /* if and when someone fully debugs the case sensitive mode */
868 if ((e_spec[1] == 'D') &&
869 (e_spec[2] == 'I') &&
870 (e_spec[3] == 'R')) {
879 * Routine to retrieve the maximum equivalence index for an input
880 * logical name. Some calls to this routine have no knowledge if
881 * the variable is a logical or not. So on error we return a max
884 /*{{{int my_maxidx(const char *lnm) */
886 my_maxidx(const char *lnm)
890 int attr = LNM$M_CASE_BLIND;
891 struct dsc$descriptor lnmdsc;
892 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
895 lnmdsc.dsc$w_length = strlen(lnm);
896 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
897 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
898 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
900 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
901 if ((status & 1) == 0)
908 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
910 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
911 struct dsc$descriptor_s **tabvec, unsigned long int flags)
914 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
915 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
916 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
918 unsigned char acmode;
919 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
920 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
921 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
922 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
924 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
925 #if defined(PERL_IMPLICIT_CONTEXT)
928 aTHX = PERL_GET_INTERP;
934 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
935 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
937 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
938 *cp2 = _toupper(*cp1);
939 if (cp1 - lnm > LNM$C_NAMLENGTH) {
940 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
944 lnmdsc.dsc$w_length = cp1 - lnm;
945 lnmdsc.dsc$a_pointer = uplnm;
946 uplnm[lnmdsc.dsc$w_length] = '\0';
947 secure = flags & PERL__TRNENV_SECURE;
948 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
949 if (!tabvec || !*tabvec) tabvec = env_tables;
951 for (curtab = 0; tabvec[curtab]; curtab++) {
952 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
953 if (!ivenv && !secure) {
958 #if defined(PERL_IMPLICIT_CONTEXT)
961 "Can't read CRTL environ\n");
964 Perl_warn(aTHX_ "Can't read CRTL environ\n");
967 retsts = SS$_NOLOGNAM;
968 for (i = 0; environ[i]; i++) {
969 if ((eq = strchr(environ[i],'=')) &&
970 lnmdsc.dsc$w_length == (eq - environ[i]) &&
971 !strncmp(environ[i],uplnm,eq - environ[i])) {
973 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
974 if (!eqvlen) continue;
979 if (retsts != SS$_NOLOGNAM) break;
982 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
983 !str$case_blind_compare(&tmpdsc,&clisym)) {
984 if (!ivsym && !secure) {
985 unsigned short int deflen = LNM$C_NAMLENGTH;
986 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
987 /* dynamic dsc to accommodate possible long value */
988 _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
989 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
991 if (eqvlen > MAX_DCL_SYMBOL) {
992 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
993 eqvlen = MAX_DCL_SYMBOL;
994 /* Special hack--we might be called before the interpreter's */
995 /* fully initialized, in which case either thr or PL_curcop */
996 /* might be bogus. We have to check, since ckWARN needs them */
997 /* both to be valid if running threaded */
998 #if defined(PERL_IMPLICIT_CONTEXT)
1001 "Value of CLI symbol \"%s\" too long",lnm);
1004 if (ckWARN(WARN_MISC)) {
1005 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1008 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1010 _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1011 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1012 if (retsts == LIB$_NOSUCHSYM) continue;
1017 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1018 midx = my_maxidx(lnm);
1019 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1020 lnmlst[1].bufadr = cp2;
1022 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1023 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1024 if (retsts == SS$_NOLOGNAM) break;
1025 /* PPFs have a prefix */
1028 *((int *)uplnm) == *((int *)"SYS$") &&
1030 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1031 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1032 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1033 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1034 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
1035 memmove(eqv,eqv+4,eqvlen-4);
1041 if ((retsts == SS$_IVLOGNAM) ||
1042 (retsts == SS$_NOLOGNAM)) { continue; }
1045 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1046 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1047 if (retsts == SS$_NOLOGNAM) continue;
1050 eqvlen = strlen(eqv);
1054 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1055 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1056 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1057 retsts == SS$_NOLOGNAM) {
1058 set_errno(EINVAL); set_vaxc_errno(retsts);
1060 else _ckvmssts_noperl(retsts);
1062 } /* end of vmstrnenv */
1065 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1066 /* Define as a function so we can access statics. */
1067 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1071 #if defined(PERL_IMPLICIT_CONTEXT)
1074 #ifdef SECURE_INTERNAL_GETENV
1075 flags = (PL_curinterp ? PL_tainting : will_taint) ?
1076 PERL__TRNENV_SECURE : 0;
1079 return vmstrnenv(lnm, eqv, idx, fildev, flags);
1084 * Note: Uses Perl temp to store result so char * can be returned to
1085 * caller; this pointer will be invalidated at next Perl statement
1087 * We define this as a function rather than a macro in terms of my_getenv_len()
1088 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1091 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1093 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1096 static char *__my_getenv_eqv = NULL;
1097 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1098 unsigned long int idx = 0;
1099 int success, secure, saverr, savvmserr;
1103 midx = my_maxidx(lnm) + 1;
1105 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1106 /* Set up a temporary buffer for the return value; Perl will
1107 * clean it up at the next statement transition */
1108 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1109 if (!tmpsv) return NULL;
1113 /* Assume no interpreter ==> single thread */
1114 if (__my_getenv_eqv != NULL) {
1115 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1118 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1120 eqv = __my_getenv_eqv;
1123 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1124 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1126 getcwd(eqv,LNM$C_NAMLENGTH);
1130 /* Get rid of "000000/ in rooted filespecs */
1133 zeros = strstr(eqv, "/000000/");
1134 if (zeros != NULL) {
1136 mlen = len - (zeros - eqv) - 7;
1137 memmove(zeros, &zeros[7], mlen);
1145 /* Impose security constraints only if tainting */
1147 /* Impose security constraints only if tainting */
1148 secure = PL_curinterp ? PL_tainting : will_taint;
1149 saverr = errno; savvmserr = vaxc$errno;
1156 #ifdef SECURE_INTERNAL_GETENV
1157 secure ? PERL__TRNENV_SECURE : 0
1163 /* For the getenv interface we combine all the equivalence names
1164 * of a search list logical into one value to acquire a maximum
1165 * value length of 255*128 (assuming %ENV is using logicals).
1167 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1169 /* If the name contains a semicolon-delimited index, parse it
1170 * off and make sure we only retrieve the equivalence name for
1172 if ((cp2 = strchr(lnm,';')) != NULL) {
1173 my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1174 idx = strtoul(cp2+1,NULL,0);
1176 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1179 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1181 /* Discard NOLOGNAM on internal calls since we're often looking
1182 * for an optional name, and this "error" often shows up as the
1183 * (bogus) exit status for a die() call later on. */
1184 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1185 return success ? eqv : NULL;
1188 } /* end of my_getenv() */
1192 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1194 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1198 unsigned long idx = 0;
1200 static char *__my_getenv_len_eqv = NULL;
1201 int secure, saverr, savvmserr;
1204 midx = my_maxidx(lnm) + 1;
1206 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1207 /* Set up a temporary buffer for the return value; Perl will
1208 * clean it up at the next statement transition */
1209 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1210 if (!tmpsv) return NULL;
1214 /* Assume no interpreter ==> single thread */
1215 if (__my_getenv_len_eqv != NULL) {
1216 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1219 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1221 buf = __my_getenv_len_eqv;
1224 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1225 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1228 getcwd(buf,LNM$C_NAMLENGTH);
1231 /* Get rid of "000000/ in rooted filespecs */
1233 zeros = strstr(buf, "/000000/");
1234 if (zeros != NULL) {
1236 mlen = *len - (zeros - buf) - 7;
1237 memmove(zeros, &zeros[7], mlen);
1246 /* Impose security constraints only if tainting */
1247 secure = PL_curinterp ? PL_tainting : will_taint;
1248 saverr = errno; savvmserr = vaxc$errno;
1255 #ifdef SECURE_INTERNAL_GETENV
1256 secure ? PERL__TRNENV_SECURE : 0
1262 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1264 if ((cp2 = strchr(lnm,';')) != NULL) {
1265 my_strlcpy(buf, lnm, cp2 - lnm + 1);
1266 idx = strtoul(cp2+1,NULL,0);
1268 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1271 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1273 /* Get rid of "000000/ in rooted filespecs */
1276 zeros = strstr(buf, "/000000/");
1277 if (zeros != NULL) {
1279 mlen = *len - (zeros - buf) - 7;
1280 memmove(zeros, &zeros[7], mlen);
1286 /* Discard NOLOGNAM on internal calls since we're often looking
1287 * for an optional name, and this "error" often shows up as the
1288 * (bogus) exit status for a die() call later on. */
1289 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1290 return *len ? buf : NULL;
1293 } /* end of my_getenv_len() */
1296 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1298 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1300 /*{{{ void prime_env_iter() */
1302 prime_env_iter(void)
1303 /* Fill the %ENV associative array with all logical names we can
1304 * find, in preparation for iterating over it.
1307 static int primed = 0;
1308 HV *seenhv = NULL, *envhv;
1310 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1311 unsigned short int chan;
1312 #ifndef CLI$M_TRUSTED
1313 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1315 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1316 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1318 bool have_sym = FALSE, have_lnm = FALSE;
1319 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1320 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1321 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1322 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1323 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1324 #if defined(PERL_IMPLICIT_CONTEXT)
1327 #if defined(USE_ITHREADS)
1328 static perl_mutex primenv_mutex;
1329 MUTEX_INIT(&primenv_mutex);
1332 #if defined(PERL_IMPLICIT_CONTEXT)
1333 /* We jump through these hoops because we can be called at */
1334 /* platform-specific initialization time, which is before anything is */
1335 /* set up--we can't even do a plain dTHX since that relies on the */
1336 /* interpreter structure to be initialized */
1338 aTHX = PERL_GET_INTERP;
1340 /* we never get here because the NULL pointer will cause the */
1341 /* several of the routines called by this routine to access violate */
1343 /* This routine is only called by hv.c/hv_iterinit which has a */
1344 /* context, so the real fix may be to pass it through instead of */
1345 /* the hoops above */
1350 if (primed || !PL_envgv) return;
1351 MUTEX_LOCK(&primenv_mutex);
1352 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1353 envhv = GvHVn(PL_envgv);
1354 /* Perform a dummy fetch as an lval to insure that the hash table is
1355 * set up. Otherwise, the hv_store() will turn into a nullop. */
1356 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1358 for (i = 0; env_tables[i]; i++) {
1359 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1360 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1361 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1363 if (have_sym || have_lnm) {
1364 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1365 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1366 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1367 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1370 for (i--; i >= 0; i--) {
1371 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1374 for (j = 0; environ[j]; j++) {
1375 if (!(start = strchr(environ[j],'='))) {
1376 if (ckWARN(WARN_INTERNAL))
1377 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1381 sv = newSVpv(start,0);
1383 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1388 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1389 !str$case_blind_compare(&tmpdsc,&clisym)) {
1390 my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1391 cmddsc.dsc$w_length = 20;
1392 if (env_tables[i]->dsc$w_length == 12 &&
1393 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1394 !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local *", sizeof(cmd)-12);
1395 flags = defflags | CLI$M_NOLOGNAM;
1398 my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1399 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1400 my_strlcat(cmd," /Table=", sizeof(cmd));
1401 cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, env_tables[i]->dsc$w_length + 1);
1403 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1404 flags = defflags | CLI$M_NOCLISYM;
1407 /* Create a new subprocess to execute each command, to exclude the
1408 * remote possibility that someone could subvert a mbx or file used
1409 * to write multiple commands to a single subprocess.
1412 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1413 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1414 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1415 defflags &= ~CLI$M_TRUSTED;
1416 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1418 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1419 if (seenhv) SvREFCNT_dec(seenhv);
1422 char *cp1, *cp2, *key;
1423 unsigned long int sts, iosb[2], retlen, keylen;
1426 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1427 if (sts & 1) sts = iosb[0] & 0xffff;
1428 if (sts == SS$_ENDOFFILE) {
1430 while (substs == 0) { sys$hiber(); wakect++;}
1431 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1436 retlen = iosb[0] >> 16;
1437 if (!retlen) continue; /* blank line */
1439 if (iosb[1] != subpid) {
1441 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1445 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1446 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1448 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1449 if (*cp1 == '(' || /* Logical name table name */
1450 *cp1 == '=' /* Next eqv of searchlist */) continue;
1451 if (*cp1 == '"') cp1++;
1452 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1453 key = cp1; keylen = cp2 - cp1;
1454 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1455 while (*cp2 && *cp2 != '=') cp2++;
1456 while (*cp2 && *cp2 == '=') cp2++;
1457 while (*cp2 && *cp2 == ' ') cp2++;
1458 if (*cp2 == '"') { /* String translation; may embed "" */
1459 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1460 cp2++; cp1--; /* Skip "" surrounding translation */
1462 else { /* Numeric translation */
1463 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1464 cp1--; /* stop on last non-space char */
1466 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1467 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1470 PERL_HASH(hash,key,keylen);
1472 if (cp1 == cp2 && *cp2 == '.') {
1473 /* A single dot usually means an unprintable character, such as a null
1474 * to indicate a zero-length value. Get the actual value to make sure.
1476 char lnm[LNM$C_NAMLENGTH+1];
1477 char eqv[MAX_DCL_SYMBOL+1];
1479 strncpy(lnm, key, keylen);
1480 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1481 sv = newSVpvn(eqv, strlen(eqv));
1484 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1488 hv_store(envhv,key,keylen,sv,hash);
1489 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1491 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1492 /* get the PPFs for this process, not the subprocess */
1493 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1494 char eqv[LNM$C_NAMLENGTH+1];
1496 for (i = 0; ppfs[i]; i++) {
1497 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1498 sv = newSVpv(eqv,trnlen);
1500 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1505 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1506 if (buf) Safefree(buf);
1507 if (seenhv) SvREFCNT_dec(seenhv);
1508 MUTEX_UNLOCK(&primenv_mutex);
1511 } /* end of prime_env_iter */
1515 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1516 /* Define or delete an element in the same "environment" as
1517 * vmstrnenv(). If an element is to be deleted, it's removed from
1518 * the first place it's found. If it's to be set, it's set in the
1519 * place designated by the first element of the table vector.
1520 * Like setenv() returns 0 for success, non-zero on error.
1523 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1526 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1527 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1529 unsigned long int retsts, usermode = PSL$C_USER;
1530 struct itmlst_3 *ile, *ilist;
1531 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1532 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1533 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1534 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1535 $DESCRIPTOR(local,"_LOCAL");
1538 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1539 return SS$_IVLOGNAM;
1542 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1543 *cp2 = _toupper(*cp1);
1544 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1545 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1546 return SS$_IVLOGNAM;
1549 lnmdsc.dsc$w_length = cp1 - lnm;
1550 if (!tabvec || !*tabvec) tabvec = env_tables;
1552 if (!eqv) { /* we're deleting n element */
1553 for (curtab = 0; tabvec[curtab]; curtab++) {
1554 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1556 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1557 if ((cp1 = strchr(environ[i],'=')) &&
1558 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1559 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1561 return setenv(lnm,"",1) ? vaxc$errno : 0;
1564 ivenv = 1; retsts = SS$_NOLOGNAM;
1566 if (ckWARN(WARN_INTERNAL))
1567 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1568 ivenv = 1; retsts = SS$_NOSUCHPGM;
1574 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1575 !str$case_blind_compare(&tmpdsc,&clisym)) {
1576 unsigned int symtype;
1577 if (tabvec[curtab]->dsc$w_length == 12 &&
1578 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1579 !str$case_blind_compare(&tmpdsc,&local))
1580 symtype = LIB$K_CLI_LOCAL_SYM;
1581 else symtype = LIB$K_CLI_GLOBAL_SYM;
1582 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1583 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1584 if (retsts == LIB$_NOSUCHSYM) continue;
1588 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1589 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1590 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1591 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1592 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1596 else { /* we're defining a value */
1597 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1599 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1601 if (ckWARN(WARN_INTERNAL))
1602 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1603 retsts = SS$_NOSUCHPGM;
1607 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1608 eqvdsc.dsc$w_length = strlen(eqv);
1609 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1610 !str$case_blind_compare(&tmpdsc,&clisym)) {
1611 unsigned int symtype;
1612 if (tabvec[0]->dsc$w_length == 12 &&
1613 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1614 !str$case_blind_compare(&tmpdsc,&local))
1615 symtype = LIB$K_CLI_LOCAL_SYM;
1616 else symtype = LIB$K_CLI_GLOBAL_SYM;
1617 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1620 if (!*eqv) eqvdsc.dsc$w_length = 1;
1621 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1623 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1624 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1625 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1626 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1627 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1628 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1631 Newx(ilist,nseg+1,struct itmlst_3);
1634 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1637 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1639 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1640 ile->itmcode = LNM$_STRING;
1642 if ((j+1) == nseg) {
1643 ile->buflen = strlen(c);
1644 /* in case we are truncating one that's too long */
1645 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1648 ile->buflen = LNM$C_NAMLENGTH;
1652 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1656 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1661 if (!(retsts & 1)) {
1663 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1664 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1665 set_errno(EVMSERR); break;
1666 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1667 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1668 set_errno(EINVAL); break;
1670 set_errno(EACCES); break;
1675 set_vaxc_errno(retsts);
1676 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1679 /* We reset error values on success because Perl does an hv_fetch()
1680 * before each hv_store(), and if the thing we're setting didn't
1681 * previously exist, we've got a leftover error message. (Of course,
1682 * this fails in the face of
1683 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1684 * in that the error reported in $! isn't spurious,
1685 * but it's right more often than not.)
1687 set_errno(0); set_vaxc_errno(retsts);
1691 } /* end of vmssetenv() */
1694 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1695 /* This has to be a function since there's a prototype for it in proto.h */
1697 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1700 int len = strlen(lnm);
1704 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1705 if (!strcmp(uplnm,"DEFAULT")) {
1706 if (eqv && *eqv) my_chdir(eqv);
1711 (void) vmssetenv(lnm,eqv,NULL);
1715 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1717 * sets a user-mode logical in the process logical name table
1718 * used for redirection of sys$error
1720 * Fix-me: The pTHX is not needed for this routine, however doio.c
1721 * is calling it with one instead of using a macro.
1722 * A macro needs to be added to vmsish.h and doio.c updated to use it.
1726 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1728 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1729 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1730 unsigned long int iss, attr = LNM$M_CONFINE;
1731 unsigned char acmode = PSL$C_USER;
1732 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1734 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1735 d_name.dsc$w_length = strlen(name);
1737 lnmlst[0].buflen = strlen(eqv);
1738 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1740 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1741 if (!(iss&1)) lib$signal(iss);
1746 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1747 /* my_crypt - VMS password hashing
1748 * my_crypt() provides an interface compatible with the Unix crypt()
1749 * C library function, and uses sys$hash_password() to perform VMS
1750 * password hashing. The quadword hashed password value is returned
1751 * as a NUL-terminated 8 character string. my_crypt() does not change
1752 * the case of its string arguments; in order to match the behavior
1753 * of LOGINOUT et al., alphabetic characters in both arguments must
1754 * be upcased by the caller.
1756 * - fix me to call ACM services when available
1759 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1761 # ifndef UAI$C_PREFERRED_ALGORITHM
1762 # define UAI$C_PREFERRED_ALGORITHM 127
1764 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1765 unsigned short int salt = 0;
1766 unsigned long int sts;
1768 unsigned short int dsc$w_length;
1769 unsigned char dsc$b_type;
1770 unsigned char dsc$b_class;
1771 const char * dsc$a_pointer;
1772 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1773 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1774 struct itmlst_3 uailst[3] = {
1775 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1776 { sizeof salt, UAI$_SALT, &salt, 0},
1777 { 0, 0, NULL, NULL}};
1778 static char hash[9];
1780 usrdsc.dsc$w_length = strlen(usrname);
1781 usrdsc.dsc$a_pointer = usrname;
1782 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1784 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1788 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1793 set_vaxc_errno(sts);
1794 if (sts != RMS$_RNF) return NULL;
1797 txtdsc.dsc$w_length = strlen(textpasswd);
1798 txtdsc.dsc$a_pointer = textpasswd;
1799 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1800 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1803 return (char *) hash;
1805 } /* end of my_crypt() */
1809 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1810 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1811 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1813 /* fixup barenames that are directories for internal use.
1814 * There have been problems with the consistent handling of UNIX
1815 * style directory names when routines are presented with a name that
1816 * has no directory delimiters at all. So this routine will eventually
1819 static char * fixup_bare_dirnames(const char * name)
1821 if (decc_disable_to_vms_logname_translation) {
1827 /* 8.3, remove() is now broken on symbolic links */
1828 static int rms_erase(const char * vmsname);
1832 * A little hack to get around a bug in some implementation of remove()
1833 * that do not know how to delete a directory
1835 * Delete any file to which user has control access, regardless of whether
1836 * delete access is explicitly allowed.
1837 * Limitations: User must have write access to parent directory.
1838 * Does not block signals or ASTs; if interrupted in midstream
1839 * may leave file with an altered ACL.
1842 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1844 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1848 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1849 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1850 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1852 unsigned char myace$b_length;
1853 unsigned char myace$b_type;
1854 unsigned short int myace$w_flags;
1855 unsigned long int myace$l_access;
1856 unsigned long int myace$l_ident;
1857 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1858 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1859 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1861 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1862 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1863 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1864 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1865 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1866 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1868 /* Expand the input spec using RMS, since the CRTL remove() and
1869 * system services won't do this by themselves, so we may miss
1870 * a file "hiding" behind a logical name or search list. */
1871 vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1872 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1874 rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1876 PerlMem_free(vmsname);
1880 /* Erase the file */
1881 rmsts = rms_erase(vmsname);
1883 /* Did it succeed */
1884 if ($VMS_STATUS_SUCCESS(rmsts)) {
1885 PerlMem_free(vmsname);
1889 /* If not, can changing protections help? */
1890 if (rmsts != RMS$_PRV) {
1891 set_vaxc_errno(rmsts);
1892 PerlMem_free(vmsname);
1896 /* No, so we get our own UIC to use as a rights identifier,
1897 * and the insert an ACE at the head of the ACL which allows us
1898 * to delete the file.
1900 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1901 fildsc.dsc$w_length = strlen(vmsname);
1902 fildsc.dsc$a_pointer = vmsname;
1904 newace.myace$l_ident = oldace.myace$l_ident;
1906 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1908 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1909 set_errno(ENOENT); break;
1911 set_errno(ENOTDIR); break;
1913 set_errno(ENODEV); break;
1914 case RMS$_SYN: case SS$_INVFILFOROP:
1915 set_errno(EINVAL); break;
1917 set_errno(EACCES); break;
1919 _ckvmssts_noperl(aclsts);
1921 set_vaxc_errno(aclsts);
1922 PerlMem_free(vmsname);
1925 /* Grab any existing ACEs with this identifier in case we fail */
1926 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1927 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1928 || fndsts == SS$_NOMOREACE ) {
1929 /* Add the new ACE . . . */
1930 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1933 rmsts = rms_erase(vmsname);
1934 if ($VMS_STATUS_SUCCESS(rmsts)) {
1939 /* We blew it - dir with files in it, no write priv for
1940 * parent directory, etc. Put things back the way they were. */
1941 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1944 addlst[0].bufadr = &oldace;
1945 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1952 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1953 /* We just deleted it, so of course it's not there. Some versions of
1954 * VMS seem to return success on the unlock operation anyhow (after all
1955 * the unlock is successful), but others don't.
1957 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1958 if (aclsts & 1) aclsts = fndsts;
1959 if (!(aclsts & 1)) {
1961 set_vaxc_errno(aclsts);
1964 PerlMem_free(vmsname);
1967 } /* end of kill_file() */
1971 /*{{{int do_rmdir(char *name)*/
1973 Perl_do_rmdir(pTHX_ const char *name)
1979 /* lstat returns a VMS fileified specification of the name */
1980 /* that is looked up, and also lets verifies that this is a directory */
1982 retval = flex_lstat(name, &st);
1986 /* Due to a historical feature, flex_stat/lstat can not see some */
1987 /* Unix format file names that the rest of the CRTL can see */
1988 /* Fixing that feature will cause some perl tests to fail */
1989 /* So try this one more time. */
1991 retval = lstat(name, &st.crtl_stat);
1995 /* force it to a file spec for the kill file to work. */
1996 ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1997 if (ret_spec == NULL) {
2003 if (!S_ISDIR(st.st_mode)) {
2008 dirfile = st.st_devnam;
2010 /* It may be possible for flex_stat to find a file and vmsify() to */
2011 /* fail with ODS-2 specifications. mp_do_kill_file can not deal */
2012 /* with that case, so fail it */
2013 if (dirfile[0] == 0) {
2018 retval = mp_do_kill_file(aTHX_ dirfile, 1);
2023 } /* end of do_rmdir */
2027 * Delete any file to which user has control access, regardless of whether
2028 * delete access is explicitly allowed.
2029 * Limitations: User must have write access to parent directory.
2030 * Does not block signals or ASTs; if interrupted in midstream
2031 * may leave file with an altered ACL.
2034 /*{{{int kill_file(char *name)*/
2036 Perl_kill_file(pTHX_ const char *name)
2042 /* Convert the filename to VMS format and see if it is a directory */
2043 /* flex_lstat returns a vmsified file specification */
2044 rmsts = flex_lstat(name, &st);
2047 /* Due to a historical feature, flex_stat/lstat can not see some */
2048 /* Unix format file names that the rest of the CRTL can see when */
2049 /* ODS-2 file specifications are in use. */
2050 /* Fixing that feature will cause some perl tests to fail */
2051 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2053 vmsfile = (char *) name; /* cast ok */
2056 vmsfile = st.st_devnam;
2057 if (vmsfile[0] == 0) {
2058 /* It may be possible for flex_stat to find a file and vmsify() */
2059 /* to fail with ODS-2 specifications. mp_do_kill_file can not */
2060 /* deal with that case, so fail it */
2066 /* Remove() is allowed to delete directories, according to the X/Open
2068 * This may need special handling to work with the ACL hacks.
2070 if (S_ISDIR(st.st_mode)) {
2071 rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2075 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2077 /* Need to delete all versions ? */
2078 if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2081 /* Just use lstat() here as do not need st_dev */
2082 /* and we know that the file is in VMS format or that */
2083 /* because of a historical bug, flex_stat can not see the file */
2084 while (lstat(vmsfile, (stat_t *)&st) == 0) {
2085 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2090 /* Make sure that we do not loop forever */
2101 } /* end of kill_file() */
2105 /*{{{int my_mkdir(char *,Mode_t)*/
2107 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2109 STRLEN dirlen = strlen(dir);
2111 /* zero length string sometimes gives ACCVIO */
2112 if (dirlen == 0) return -1;
2114 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2115 * null file name/type. However, it's commonplace under Unix,
2116 * so we'll allow it for a gain in portability.
2118 if (dir[dirlen-1] == '/') {
2119 char *newdir = savepvn(dir,dirlen-1);
2120 int ret = mkdir(newdir,mode);
2124 else return mkdir(dir,mode);
2125 } /* end of my_mkdir */
2128 /*{{{int my_chdir(char *)*/
2130 Perl_my_chdir(pTHX_ const char *dir)
2132 STRLEN dirlen = strlen(dir);
2134 /* zero length string sometimes gives ACCVIO */
2135 if (dirlen == 0) return -1;
2138 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2139 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2140 * so that existing scripts do not need to be changed.
2143 while ((dirlen > 0) && (*dir1 == ' ')) {
2148 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2150 * null file name/type. However, it's commonplace under Unix,
2151 * so we'll allow it for a gain in portability.
2153 * '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2155 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2158 newdir = (char *)PerlMem_malloc(dirlen);
2160 _ckvmssts_noperl(SS$_INSFMEM);
2161 memcpy(newdir, dir1, dirlen-1);
2162 newdir[dirlen-1] = '\0';
2163 ret = chdir(newdir);
2164 PerlMem_free(newdir);
2167 else return chdir(dir1);
2168 } /* end of my_chdir */
2172 /*{{{int my_chmod(char *, mode_t)*/
2174 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2179 STRLEN speclen = strlen(file_spec);
2181 /* zero length string sometimes gives ACCVIO */
2182 if (speclen == 0) return -1;
2184 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2185 * that implies null file name/type. However, it's commonplace under Unix,
2186 * so we'll allow it for a gain in portability.
2188 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2189 * in VMS file.dir notation.
2191 changefile = (char *) file_spec; /* cast ok */
2192 ret = flex_lstat(file_spec, &st);
2195 /* Due to a historical feature, flex_stat/lstat can not see some */
2196 /* Unix format file names that the rest of the CRTL can see when */
2197 /* ODS-2 file specifications are in use. */
2198 /* Fixing that feature will cause some perl tests to fail */
2199 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2203 /* It may be possible to get here with nothing in st_devname */
2204 /* chmod still may work though */
2205 if (st.st_devnam[0] != 0) {
2206 changefile = st.st_devnam;
2209 ret = chmod(changefile, mode);
2211 } /* end of my_chmod */
2215 /*{{{FILE *my_tmpfile()*/
2222 if ((fp = tmpfile())) return fp;
2224 cp = (char *)PerlMem_malloc(L_tmpnam+24);
2225 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2227 if (decc_filename_unix_only == 0)
2228 strcpy(cp,"Sys$Scratch:");
2231 tmpnam(cp+strlen(cp));
2232 strcat(cp,".Perltmp");
2233 fp = fopen(cp,"w+","fop=dlt");
2241 * The C RTL's sigaction fails to check for invalid signal numbers so we
2242 * help it out a bit. The docs are correct, but the actual routine doesn't
2243 * do what the docs say it will.
2245 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2247 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2248 struct sigaction* oact)
2250 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2251 SETERRNO(EINVAL, SS$_INVARG);
2254 return sigaction(sig, act, oact);
2258 #ifdef KILL_BY_SIGPRC
2259 #include <errnodef.h>
2261 /* We implement our own kill() using the undocumented system service
2262 sys$sigprc for one of two reasons:
2264 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2265 target process to do a sys$exit, which usually can't be handled
2266 gracefully...certainly not by Perl and the %SIG{} mechanism.
2268 2.) If the kill() in the CRTL can't be called from a signal
2269 handler without disappearing into the ether, i.e., the signal
2270 it purportedly sends is never trapped. Still true as of VMS 7.3.
2272 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2273 in the target process rather than calling sys$exit.
2275 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2276 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2277 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2278 with condition codes C$_SIG0+nsig*8, catching the exception on the
2279 target process and resignaling with appropriate arguments.
2281 But we don't have that VMS 7.0+ exception handler, so if you
2282 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2284 Also note that SIGTERM is listed in the docs as being "unimplemented",
2285 yet always seems to be signaled with a VMS condition code of 4 (and
2286 correctly handled for that code). So we hardwire it in.
2288 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2289 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2290 than signalling with an unrecognized (and unhandled by CRTL) code.
2293 #define _MY_SIG_MAX 28
2296 Perl_sig_to_vmscondition_int(int sig)
2298 static unsigned int sig_code[_MY_SIG_MAX+1] =
2301 SS$_HANGUP, /* 1 SIGHUP */
2302 SS$_CONTROLC, /* 2 SIGINT */
2303 SS$_CONTROLY, /* 3 SIGQUIT */
2304 SS$_RADRMOD, /* 4 SIGILL */
2305 SS$_BREAK, /* 5 SIGTRAP */
2306 SS$_OPCCUS, /* 6 SIGABRT */
2307 SS$_COMPAT, /* 7 SIGEMT */
2309 SS$_FLTOVF, /* 8 SIGFPE VAX */
2311 SS$_HPARITH, /* 8 SIGFPE AXP */
2313 SS$_ABORT, /* 9 SIGKILL */
2314 SS$_ACCVIO, /* 10 SIGBUS */
2315 SS$_ACCVIO, /* 11 SIGSEGV */
2316 SS$_BADPARAM, /* 12 SIGSYS */
2317 SS$_NOMBX, /* 13 SIGPIPE */
2318 SS$_ASTFLT, /* 14 SIGALRM */
2335 static int initted = 0;
2338 sig_code[16] = C$_SIGUSR1;
2339 sig_code[17] = C$_SIGUSR2;
2340 sig_code[20] = C$_SIGCHLD;
2341 #if __CRTL_VER >= 70300000
2342 sig_code[28] = C$_SIGWINCH;
2346 if (sig < _SIG_MIN) return 0;
2347 if (sig > _MY_SIG_MAX) return 0;
2348 return sig_code[sig];
2352 Perl_sig_to_vmscondition(int sig)
2355 if (vms_debug_on_exception != 0)
2356 lib$signal(SS$_DEBUG);
2358 return Perl_sig_to_vmscondition_int(sig);
2362 #define sys$sigprc SYS$SIGPRC
2366 int sys$sigprc(unsigned int *pidadr,
2367 struct dsc$descriptor_s *prcname,
2374 Perl_my_kill(int pid, int sig)
2379 /* sig 0 means validate the PID */
2380 /*------------------------------*/
2382 const unsigned long int jpicode = JPI$_PID;
2385 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2386 if ($VMS_STATUS_SUCCESS(status))
2389 case SS$_NOSUCHNODE:
2390 case SS$_UNREACHABLE:
2404 code = Perl_sig_to_vmscondition_int(sig);
2407 SETERRNO(EINVAL, SS$_BADPARAM);
2411 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2412 * signals are to be sent to multiple processes.
2413 * pid = 0 - all processes in group except ones that the system exempts
2414 * pid = -1 - all processes except ones that the system exempts
2415 * pid = -n - all processes in group (abs(n)) except ...
2416 * For now, just report as not supported.
2420 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2424 iss = sys$sigprc((unsigned int *)&pid,0,code);
2425 if (iss&1) return 0;
2429 set_errno(EPERM); break;
2431 case SS$_NOSUCHNODE:
2432 case SS$_UNREACHABLE:
2433 set_errno(ESRCH); break;
2435 set_errno(ENOMEM); break;
2437 _ckvmssts_noperl(iss);
2440 set_vaxc_errno(iss);
2446 /* Routine to convert a VMS status code to a UNIX status code.
2447 ** More tricky than it appears because of conflicting conventions with
2450 ** VMS status codes are a bit mask, with the least significant bit set for
2453 ** Special UNIX status of EVMSERR indicates that no translation is currently
2454 ** available, and programs should check the VMS status code.
2456 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2460 #ifndef C_FACILITY_NO
2461 #define C_FACILITY_NO 0x350000
2464 #define DCL_IVVERB 0x38090
2467 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2475 /* Assume the best or the worst */
2476 if (vms_status & STS$M_SUCCESS)
2479 unix_status = EVMSERR;
2481 msg_status = vms_status & ~STS$M_CONTROL;
2483 facility = vms_status & STS$M_FAC_NO;
2484 fac_sp = vms_status & STS$M_FAC_SP;
2485 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2487 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2493 unix_status = EFAULT;
2495 case SS$_DEVOFFLINE:
2496 unix_status = EBUSY;
2499 unix_status = ENOTCONN;
2507 case SS$_INVFILFOROP:
2511 unix_status = EINVAL;
2513 case SS$_UNSUPPORTED:
2514 unix_status = ENOTSUP;
2519 unix_status = EACCES;
2521 case SS$_DEVICEFULL:
2522 unix_status = ENOSPC;
2525 unix_status = ENODEV;
2527 case SS$_NOSUCHFILE:
2528 case SS$_NOSUCHOBJECT:
2529 unix_status = ENOENT;
2531 case SS$_ABORT: /* Fatal case */
2532 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2533 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2534 unix_status = EINTR;
2537 unix_status = E2BIG;
2540 unix_status = ENOMEM;
2543 unix_status = EPERM;
2545 case SS$_NOSUCHNODE:
2546 case SS$_UNREACHABLE:
2547 unix_status = ESRCH;
2550 unix_status = ECHILD;
2553 if ((facility == 0) && (msg_no < 8)) {
2554 /* These are not real VMS status codes so assume that they are
2555 ** already UNIX status codes
2557 unix_status = msg_no;
2563 /* Translate a POSIX exit code to a UNIX exit code */
2564 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2565 unix_status = (msg_no & 0x07F8) >> 3;
2569 /* Documented traditional behavior for handling VMS child exits */
2570 /*--------------------------------------------------------------*/
2571 if (child_flag != 0) {
2573 /* Success / Informational return 0 */
2574 /*----------------------------------*/
2575 if (msg_no & STS$K_SUCCESS)
2578 /* Warning returns 1 */
2579 /*-------------------*/
2580 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2583 /* Everything else pass through the severity bits */
2584 /*------------------------------------------------*/
2585 return (msg_no & STS$M_SEVERITY);
2588 /* Normal VMS status to ERRNO mapping attempt */
2589 /*--------------------------------------------*/
2590 switch(msg_status) {
2591 /* case RMS$_EOF: */ /* End of File */
2592 case RMS$_FNF: /* File Not Found */
2593 case RMS$_DNF: /* Dir Not Found */
2594 unix_status = ENOENT;
2596 case RMS$_RNF: /* Record Not Found */
2597 unix_status = ESRCH;
2600 unix_status = ENOTDIR;
2603 unix_status = ENODEV;
2608 unix_status = EBADF;
2611 unix_status = EEXIST;
2615 case LIB$_INVSTRDES:
2617 case LIB$_NOSUCHSYM:
2618 case LIB$_INVSYMNAM:
2620 unix_status = EINVAL;
2626 unix_status = E2BIG;
2628 case RMS$_PRV: /* No privilege */
2629 case RMS$_ACC: /* ACP file access failed */
2630 case RMS$_WLK: /* Device write locked */
2631 unix_status = EACCES;
2633 case RMS$_MKD: /* Failed to mark for delete */
2634 unix_status = EPERM;
2636 /* case RMS$_NMF: */ /* No more files */
2644 /* Try to guess at what VMS error status should go with a UNIX errno
2645 * value. This is hard to do as there could be many possible VMS
2646 * error statuses that caused the errno value to be set.
2649 int Perl_unix_status_to_vms(int unix_status)
2651 int test_unix_status;
2653 /* Trivial cases first */
2654 /*---------------------*/
2655 if (unix_status == EVMSERR)
2658 /* Is vaxc$errno sane? */
2659 /*---------------------*/
2660 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2661 if (test_unix_status == unix_status)
2664 /* If way out of range, must be VMS code already */
2665 /*-----------------------------------------------*/
2666 if (unix_status > EVMSERR)
2669 /* If out of range, punt */
2670 /*-----------------------*/
2671 if (unix_status > __ERRNO_MAX)
2675 /* Ok, now we have to do it the hard way. */
2676 /*----------------------------------------*/
2677 switch(unix_status) {
2678 case 0: return SS$_NORMAL;
2679 case EPERM: return SS$_NOPRIV;
2680 case ENOENT: return SS$_NOSUCHOBJECT;
2681 case ESRCH: return SS$_UNREACHABLE;
2682 case EINTR: return SS$_ABORT;
2685 case E2BIG: return SS$_BUFFEROVF;
2687 case EBADF: return RMS$_IFI;
2688 case ECHILD: return SS$_NONEXPR;
2690 case ENOMEM: return SS$_INSFMEM;
2691 case EACCES: return SS$_FILACCERR;
2692 case EFAULT: return SS$_ACCVIO;
2694 case EBUSY: return SS$_DEVOFFLINE;
2695 case EEXIST: return RMS$_FEX;
2697 case ENODEV: return SS$_NOSUCHDEV;
2698 case ENOTDIR: return RMS$_DIR;
2700 case EINVAL: return SS$_INVARG;
2706 case ENOSPC: return SS$_DEVICEFULL;
2707 case ESPIPE: return LIB$_INVARG;
2712 case ERANGE: return LIB$_INVARG;
2713 /* case EWOULDBLOCK */
2714 /* case EINPROGRESS */
2717 /* case EDESTADDRREQ */
2719 /* case EPROTOTYPE */
2720 /* case ENOPROTOOPT */
2721 /* case EPROTONOSUPPORT */
2722 /* case ESOCKTNOSUPPORT */
2723 /* case EOPNOTSUPP */
2724 /* case EPFNOSUPPORT */
2725 /* case EAFNOSUPPORT */
2726 /* case EADDRINUSE */
2727 /* case EADDRNOTAVAIL */
2729 /* case ENETUNREACH */
2730 /* case ENETRESET */
2731 /* case ECONNABORTED */
2732 /* case ECONNRESET */
2735 case ENOTCONN: return SS$_CLEARED;
2736 /* case ESHUTDOWN */
2737 /* case ETOOMANYREFS */
2738 /* case ETIMEDOUT */
2739 /* case ECONNREFUSED */
2741 /* case ENAMETOOLONG */
2742 /* case EHOSTDOWN */
2743 /* case EHOSTUNREACH */
2744 /* case ENOTEMPTY */
2756 /* case ECANCELED */
2760 return SS$_UNSUPPORTED;
2766 /* case EABANDONED */
2768 return SS$_ABORT; /* punt */
2773 /* default piping mailbox size */
2775 # define PERL_BUFSIZ 512
2777 # define PERL_BUFSIZ 8192
2782 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2784 unsigned long int mbxbufsiz;
2785 static unsigned long int syssize = 0;
2786 unsigned long int dviitm = DVI$_DEVNAM;
2787 char csize[LNM$C_NAMLENGTH+1];
2791 unsigned long syiitm = SYI$_MAXBUF;
2793 * Get the SYSGEN parameter MAXBUF
2795 * If the logical 'PERL_MBX_SIZE' is defined
2796 * use the value of the logical instead of PERL_BUFSIZ, but
2797 * keep the size between 128 and MAXBUF.
2800 _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2803 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2804 mbxbufsiz = atoi(csize);
2806 mbxbufsiz = PERL_BUFSIZ;
2808 if (mbxbufsiz < 128) mbxbufsiz = 128;
2809 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2811 _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2813 sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2814 _ckvmssts_noperl(sts);
2815 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2817 } /* end of create_mbx() */
2820 /*{{{ my_popen and my_pclose*/
2822 typedef struct _iosb IOSB;
2823 typedef struct _iosb* pIOSB;
2824 typedef struct _pipe Pipe;
2825 typedef struct _pipe* pPipe;
2826 typedef struct pipe_details Info;
2827 typedef struct pipe_details* pInfo;
2828 typedef struct _srqp RQE;
2829 typedef struct _srqp* pRQE;
2830 typedef struct _tochildbuf CBuf;
2831 typedef struct _tochildbuf* pCBuf;
2834 unsigned short status;
2835 unsigned short count;
2836 unsigned long dvispec;
2839 #pragma member_alignment save
2840 #pragma nomember_alignment quadword
2841 struct _srqp { /* VMS self-relative queue entry */
2842 unsigned long qptr[2];
2844 #pragma member_alignment restore
2845 static RQE RQE_ZERO = {0,0};
2847 struct _tochildbuf {
2850 unsigned short size;
2858 unsigned short chan_in;
2859 unsigned short chan_out;
2861 unsigned int bufsize;
2873 #if defined(PERL_IMPLICIT_CONTEXT)
2874 void *thx; /* Either a thread or an interpreter */
2875 /* pointer, depending on how we're built */
2883 PerlIO *fp; /* file pointer to pipe mailbox */
2884 int useFILE; /* using stdio, not perlio */
2885 int pid; /* PID of subprocess */
2886 int mode; /* == 'r' if pipe open for reading */
2887 int done; /* subprocess has completed */
2888 int waiting; /* waiting for completion/closure */
2889 int closing; /* my_pclose is closing this pipe */
2890 unsigned long completion; /* termination status of subprocess */
2891 pPipe in; /* pipe in to sub */
2892 pPipe out; /* pipe out of sub */
2893 pPipe err; /* pipe of sub's sys$error */
2894 int in_done; /* true when in pipe finished */
2897 unsigned short xchan; /* channel to debug xterm */
2898 unsigned short xchan_valid; /* channel is assigned */
2901 struct exit_control_block
2903 struct exit_control_block *flink;
2904 unsigned long int (*exit_routine)(void);
2905 unsigned long int arg_count;
2906 unsigned long int *status_address;
2907 unsigned long int exit_status;
2910 typedef struct _closed_pipes Xpipe;
2911 typedef struct _closed_pipes* pXpipe;
2913 struct _closed_pipes {
2914 int pid; /* PID of subprocess */
2915 unsigned long completion; /* termination status of subprocess */
2917 #define NKEEPCLOSED 50
2918 static Xpipe closed_list[NKEEPCLOSED];
2919 static int closed_index = 0;
2920 static int closed_num = 0;
2922 #define RETRY_DELAY "0 ::0.20"
2923 #define MAX_RETRY 50
2925 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2926 static unsigned long mypid;
2927 static unsigned long delaytime[2];
2929 static pInfo open_pipes = NULL;
2930 static $DESCRIPTOR(nl_desc, "NL:");
2932 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2936 static unsigned long int
2937 pipe_exit_routine(void)
2940 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2941 int sts, did_stuff, j;
2944 * Flush any pending i/o, but since we are in process run-down, be
2945 * careful about referencing PerlIO structures that may already have
2946 * been deallocated. We may not even have an interpreter anymore.
2951 #if defined(PERL_IMPLICIT_CONTEXT)
2952 /* We need to use the Perl context of the thread that created */
2956 aTHX = info->err->thx;
2958 aTHX = info->out->thx;
2960 aTHX = info->in->thx;
2963 #if defined(USE_ITHREADS)
2967 && PL_perlio_fd_refcnt
2970 PerlIO_flush(info->fp);
2972 fflush((FILE *)info->fp);
2978 next we try sending an EOF...ignore if doesn't work, make sure we
2985 _ckvmssts_noperl(sys$setast(0));
2986 if (info->in && !info->in->shut_on_empty) {
2987 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2992 _ckvmssts_noperl(sys$setast(1));
2996 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2998 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3003 _ckvmssts_noperl(sys$setast(0));
3004 if (info->waiting && info->done)
3006 nwait += info->waiting;
3007 _ckvmssts_noperl(sys$setast(1));
3017 _ckvmssts_noperl(sys$setast(0));
3018 if (!info->done) { /* Tap them gently on the shoulder . . .*/
3019 sts = sys$forcex(&info->pid,0,&abort);
3020 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3023 _ckvmssts_noperl(sys$setast(1));
3027 /* again, wait for effect */
3029 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3034 _ckvmssts_noperl(sys$setast(0));
3035 if (info->waiting && info->done)
3037 nwait += info->waiting;
3038 _ckvmssts_noperl(sys$setast(1));
3047 _ckvmssts_noperl(sys$setast(0));
3048 if (!info->done) { /* We tried to be nice . . . */
3049 sts = sys$delprc(&info->pid,0);
3050 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3051 info->done = 1; /* sys$delprc is as done as we're going to get. */
3053 _ckvmssts_noperl(sys$setast(1));
3059 #if defined(PERL_IMPLICIT_CONTEXT)
3060 /* We need to use the Perl context of the thread that created */
3063 if (open_pipes->err)
3064 aTHX = open_pipes->err->thx;
3065 else if (open_pipes->out)
3066 aTHX = open_pipes->out->thx;
3067 else if (open_pipes->in)
3068 aTHX = open_pipes->in->thx;
3070 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3071 else if (!(sts & 1)) retsts = sts;
3076 static struct exit_control_block pipe_exitblock =
3077 {(struct exit_control_block *) 0,
3078 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3080 static void pipe_mbxtofd_ast(pPipe p);
3081 static void pipe_tochild1_ast(pPipe p);
3082 static void pipe_tochild2_ast(pPipe p);
3085 popen_completion_ast(pInfo info)
3087 pInfo i = open_pipes;
3090 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3091 closed_list[closed_index].pid = info->pid;
3092 closed_list[closed_index].completion = info->completion;
3094 if (closed_index == NKEEPCLOSED)
3099 if (i == info) break;
3102 if (!i) return; /* unlinked, probably freed too */
3107 Writing to subprocess ...
3108 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3110 chan_out may be waiting for "done" flag, or hung waiting
3111 for i/o completion to child...cancel the i/o. This will
3112 put it into "snarf mode" (done but no EOF yet) that discards
3115 Output from subprocess (stdout, stderr) needs to be flushed and
3116 shut down. We try sending an EOF, but if the mbx is full the pipe
3117 routine should still catch the "shut_on_empty" flag, telling it to
3118 use immediate-style reads so that "mbx empty" -> EOF.
3122 if (info->in && !info->in_done) { /* only for mode=w */
3123 if (info->in->shut_on_empty && info->in->need_wake) {
3124 info->in->need_wake = FALSE;
3125 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3127 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3131 if (info->out && !info->out_done) { /* were we also piping output? */
3132 info->out->shut_on_empty = TRUE;
3133 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3134 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3135 _ckvmssts_noperl(iss);
3138 if (info->err && !info->err_done) { /* we were piping stderr */
3139 info->err->shut_on_empty = TRUE;
3140 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3141 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3142 _ckvmssts_noperl(iss);
3144 _ckvmssts_noperl(sys$setef(pipe_ef));
3148 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3149 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3150 static void pipe_infromchild_ast(pPipe p);
3153 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3154 inside an AST routine without worrying about reentrancy and which Perl
3155 memory allocator is being used.
3157 We read data and queue up the buffers, then spit them out one at a
3158 time to the output mailbox when the output mailbox is ready for one.
3161 #define INITIAL_TOCHILDQUEUE 2
3164 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3168 char mbx1[64], mbx2[64];
3169 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3170 DSC$K_CLASS_S, mbx1},
3171 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3172 DSC$K_CLASS_S, mbx2};
3173 unsigned int dviitm = DVI$_DEVBUFSIZ;
3177 _ckvmssts_noperl(lib$get_vm(&n, &p));
3179 create_mbx(&p->chan_in , &d_mbx1);
3180 create_mbx(&p->chan_out, &d_mbx2);
3181 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3184 p->shut_on_empty = FALSE;
3185 p->need_wake = FALSE;
3188 p->iosb.status = SS$_NORMAL;
3189 p->iosb2.status = SS$_NORMAL;
3195 #ifdef PERL_IMPLICIT_CONTEXT
3199 n = sizeof(CBuf) + p->bufsize;
3201 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3202 _ckvmssts_noperl(lib$get_vm(&n, &b));
3203 b->buf = (char *) b + sizeof(CBuf);
3204 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3207 pipe_tochild2_ast(p);
3208 pipe_tochild1_ast(p);
3214 /* reads the MBX Perl is writing, and queues */
3217 pipe_tochild1_ast(pPipe p)
3220 int iss = p->iosb.status;
3221 int eof = (iss == SS$_ENDOFFILE);
3223 #ifdef PERL_IMPLICIT_CONTEXT
3229 p->shut_on_empty = TRUE;
3231 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3233 _ckvmssts_noperl(iss);
3237 b->size = p->iosb.count;
3238 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3240 p->need_wake = FALSE;
3241 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3244 p->retry = 1; /* initial call */
3247 if (eof) { /* flush the free queue, return when done */
3248 int n = sizeof(CBuf) + p->bufsize;
3250 iss = lib$remqti(&p->free, &b);
3251 if (iss == LIB$_QUEWASEMP) return;
3252 _ckvmssts_noperl(iss);
3253 _ckvmssts_noperl(lib$free_vm(&n, &b));
3257 iss = lib$remqti(&p->free, &b);
3258 if (iss == LIB$_QUEWASEMP) {
3259 int n = sizeof(CBuf) + p->bufsize;
3260 _ckvmssts_noperl(lib$get_vm(&n, &b));
3261 b->buf = (char *) b + sizeof(CBuf);
3263 _ckvmssts_noperl(iss);
3267 iss = sys$qio(0,p->chan_in,
3268 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3270 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3271 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3272 _ckvmssts_noperl(iss);
3276 /* writes queued buffers to output, waits for each to complete before
3280 pipe_tochild2_ast(pPipe p)
3283 int iss = p->iosb2.status;
3284 int n = sizeof(CBuf) + p->bufsize;
3285 int done = (p->info && p->info->done) ||
3286 iss == SS$_CANCEL || iss == SS$_ABORT;
3287 #if defined(PERL_IMPLICIT_CONTEXT)
3292 if (p->type) { /* type=1 has old buffer, dispose */
3293 if (p->shut_on_empty) {
3294 _ckvmssts_noperl(lib$free_vm(&n, &b));
3296 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3301 iss = lib$remqti(&p->wait, &b);
3302 if (iss == LIB$_QUEWASEMP) {
3303 if (p->shut_on_empty) {
3305 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3306 *p->pipe_done = TRUE;
3307 _ckvmssts_noperl(sys$setef(pipe_ef));
3309 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3310 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3314 p->need_wake = TRUE;
3317 _ckvmssts_noperl(iss);
3324 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3325 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3327 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3328 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3337 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3340 char mbx1[64], mbx2[64];
3341 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3342 DSC$K_CLASS_S, mbx1},
3343 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3344 DSC$K_CLASS_S, mbx2};
3345 unsigned int dviitm = DVI$_DEVBUFSIZ;
3347 int n = sizeof(Pipe);
3348 _ckvmssts_noperl(lib$get_vm(&n, &p));
3349 create_mbx(&p->chan_in , &d_mbx1);
3350 create_mbx(&p->chan_out, &d_mbx2);
3352 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3353 n = p->bufsize * sizeof(char);
3354 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3355 p->shut_on_empty = FALSE;
3358 p->iosb.status = SS$_NORMAL;
3359 #if defined(PERL_IMPLICIT_CONTEXT)
3362 pipe_infromchild_ast(p);
3370 pipe_infromchild_ast(pPipe p)
3372 int iss = p->iosb.status;
3373 int eof = (iss == SS$_ENDOFFILE);
3374 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3375 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3376 #if defined(PERL_IMPLICIT_CONTEXT)
3380 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3381 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3386 input shutdown if EOF from self (done or shut_on_empty)
3387 output shutdown if closing flag set (my_pclose)
3388 send data/eof from child or eof from self
3389 otherwise, re-read (snarf of data from child)
3394 if (myeof && p->chan_in) { /* input shutdown */
3395 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3400 if (myeof || kideof) { /* pass EOF to parent */
3401 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3402 pipe_infromchild_ast, p,
3405 } else if (eof) { /* eat EOF --- fall through to read*/
3407 } else { /* transmit data */
3408 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3409 pipe_infromchild_ast,p,
3410 p->buf, p->iosb.count, 0, 0, 0, 0));
3416 /* everything shut? flag as done */
3418 if (!p->chan_in && !p->chan_out) {
3419 *p->pipe_done = TRUE;
3420 _ckvmssts_noperl(sys$setef(pipe_ef));
3424 /* write completed (or read, if snarfing from child)
3425 if still have input active,
3426 queue read...immediate mode if shut_on_empty so we get EOF if empty
3428 check if Perl reading, generate EOFs as needed
3434 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3435 pipe_infromchild_ast,p,
3436 p->buf, p->bufsize, 0, 0, 0, 0);
3437 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3438 _ckvmssts_noperl(iss);
3439 } else { /* send EOFs for extra reads */
3440 p->iosb.status = SS$_ENDOFFILE;
3441 p->iosb.dvispec = 0;
3442 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3444 pipe_infromchild_ast, p, 0, 0, 0, 0));
3450 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3454 unsigned long dviitm = DVI$_DEVBUFSIZ;
3456 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3457 DSC$K_CLASS_S, mbx};
3458 int n = sizeof(Pipe);
3460 /* things like terminals and mbx's don't need this filter */
3461 if (fd && fstat(fd,&s) == 0) {
3462 unsigned long devchar;
3464 unsigned short dev_len;
3465 struct dsc$descriptor_s d_dev;
3467 struct item_list_3 items[3];
3469 unsigned short dvi_iosb[4];
3471 cptr = getname(fd, out, 1);
3472 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3473 d_dev.dsc$a_pointer = out;
3474 d_dev.dsc$w_length = strlen(out);
3475 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3476 d_dev.dsc$b_class = DSC$K_CLASS_S;
3479 items[0].code = DVI$_DEVCHAR;
3480 items[0].bufadr = &devchar;
3481 items[0].retadr = NULL;
3483 items[1].code = DVI$_FULLDEVNAM;
3484 items[1].bufadr = device;
3485 items[1].retadr = &dev_len;
3489 status = sys$getdviw
3490 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3491 _ckvmssts_noperl(status);
3492 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3493 device[dev_len] = 0;
3495 if (!(devchar & DEV$M_DIR)) {
3496 strcpy(out, device);
3502 _ckvmssts_noperl(lib$get_vm(&n, &p));
3503 p->fd_out = dup(fd);
3504 create_mbx(&p->chan_in, &d_mbx);
3505 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3506 n = (p->bufsize+1) * sizeof(char);
3507 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3508 p->shut_on_empty = FALSE;
3513 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3514 pipe_mbxtofd_ast, p,
3515 p->buf, p->bufsize, 0, 0, 0, 0));
3521 pipe_mbxtofd_ast(pPipe p)
3523 int iss = p->iosb.status;
3524 int done = p->info->done;
3526 int eof = (iss == SS$_ENDOFFILE);
3527 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3528 int err = !(iss&1) && !eof;
3529 #if defined(PERL_IMPLICIT_CONTEXT)
3533 if (done && myeof) { /* end piping */
3535 sys$dassgn(p->chan_in);
3536 *p->pipe_done = TRUE;
3537 _ckvmssts_noperl(sys$setef(pipe_ef));
3541 if (!err && !eof) { /* good data to send to file */
3542 p->buf[p->iosb.count] = '\n';
3543 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3546 if (p->retry < MAX_RETRY) {
3547 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3553 _ckvmssts_noperl(iss);
3557 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3558 pipe_mbxtofd_ast, p,
3559 p->buf, p->bufsize, 0, 0, 0, 0);
3560 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3561 _ckvmssts_noperl(iss);
3565 typedef struct _pipeloc PLOC;
3566 typedef struct _pipeloc* pPLOC;
3570 char dir[NAM$C_MAXRSS+1];
3572 static pPLOC head_PLOC = 0;
3575 free_pipelocs(pTHX_ void *head)
3578 pPLOC *pHead = (pPLOC *)head;
3590 store_pipelocs(pTHX)
3598 char temp[NAM$C_MAXRSS+1];
3602 free_pipelocs(aTHX_ &head_PLOC);
3604 /* the . directory from @INC comes last */
3606 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3607 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3608 p->next = head_PLOC;
3610 strcpy(p->dir,"./");
3612 /* get the directory from $^X */
3614 unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3615 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3617 #ifdef PERL_IMPLICIT_CONTEXT
3618 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3620 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3622 my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3623 x = strrchr(temp,']');
3625 x = strrchr(temp,'>');
3627 /* It could be a UNIX path */
3628 x = strrchr(temp,'/');
3634 /* Got a bare name, so use default directory */
3639 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3640 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3641 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3642 p->next = head_PLOC;
3644 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3648 /* reverse order of @INC entries, skip "." since entered above */
3650 #ifdef PERL_IMPLICIT_CONTEXT
3653 if (PL_incgv) av = GvAVn(PL_incgv);
3655 for (i = 0; av && i <= AvFILL(av); i++) {
3656 dirsv = *av_fetch(av,i,TRUE);
3658 if (SvROK(dirsv)) continue;
3659 dir = SvPVx(dirsv,n_a);
3660 if (strcmp(dir,".") == 0) continue;
3661 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3664 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3665 p->next = head_PLOC;
3667 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3670 /* most likely spot (ARCHLIB) put first in the list */
3673 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3674 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3675 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3676 p->next = head_PLOC;
3678 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3681 PerlMem_free(unixdir);
3685 Perl_cando_by_name_int
3686 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3687 #if !defined(PERL_IMPLICIT_CONTEXT)
3688 #define cando_by_name_int Perl_cando_by_name_int
3690 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3696 static int vmspipe_file_status = 0;
3697 static char vmspipe_file[NAM$C_MAXRSS+1];
3699 /* already found? Check and use ... need read+execute permission */
3701 if (vmspipe_file_status == 1) {
3702 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3703 && cando_by_name_int
3704 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3705 return vmspipe_file;
3707 vmspipe_file_status = 0;
3710 /* scan through stored @INC, $^X */
3712 if (vmspipe_file_status == 0) {
3713 char file[NAM$C_MAXRSS+1];
3714 pPLOC p = head_PLOC;
3719 dirlen = my_strlcpy(file, p->dir, sizeof(file));
3720 my_strlcat(file, "vmspipe.com", sizeof(file));
3723 exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3724 if (!exp_res) continue;
3726 if (cando_by_name_int
3727 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3728 && cando_by_name_int
3729 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3730 vmspipe_file_status = 1;
3731 return vmspipe_file;
3734 vmspipe_file_status = -1; /* failed, use tempfiles */
3741 vmspipe_tempfile(pTHX)
3743 char file[NAM$C_MAXRSS+1];
3745 static int index = 0;
3749 /* create a tempfile */
3751 /* we can't go from W, shr=get to R, shr=get without
3752 an intermediate vulnerable state, so don't bother trying...
3754 and lib$spawn doesn't shr=put, so have to close the write
3756 So... match up the creation date/time and the FID to
3757 make sure we're dealing with the same file
3762 if (!decc_filename_unix_only) {
3763 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3764 fp = fopen(file,"w");
3766 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3767 fp = fopen(file,"w");
3769 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3770 fp = fopen(file,"w");
3775 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3776 fp = fopen(file,"w");
3778 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3779 fp = fopen(file,"w");
3781 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3782 fp = fopen(file,"w");
3786 if (!fp) return 0; /* we're hosed */
3788 fprintf(fp,"$! 'f$verify(0)'\n");
3789 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3790 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3791 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3792 fprintf(fp,"$ perl_on = \"set noon\"\n");
3793 fprintf(fp,"$ perl_exit = \"exit\"\n");
3794 fprintf(fp,"$ perl_del = \"delete\"\n");
3795 fprintf(fp,"$ pif = \"if\"\n");
3796 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3797 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3798 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3799 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3800 fprintf(fp,"$! --- build command line to get max possible length\n");
3801 fprintf(fp,"$c=perl_popen_cmd0\n");
3802 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3803 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3804 fprintf(fp,"$x=perl_popen_cmd3\n");
3805 fprintf(fp,"$c=c+x\n");
3806 fprintf(fp,"$ perl_on\n");
3807 fprintf(fp,"$ 'c'\n");
3808 fprintf(fp,"$ perl_status = $STATUS\n");
3809 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3810 fprintf(fp,"$ perl_exit 'perl_status'\n");
3813 fgetname(fp, file, 1);
3814 fstat(fileno(fp), &s0.crtl_stat);
3817 if (decc_filename_unix_only)
3818 int_tounixspec(file, file, NULL);
3819 fp = fopen(file,"r","shr=get");
3821 fstat(fileno(fp), &s1.crtl_stat);
3823 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3824 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3833 static int vms_is_syscommand_xterm(void)
3835 const static struct dsc$descriptor_s syscommand_dsc =
3836 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3838 const static struct dsc$descriptor_s decwdisplay_dsc =
3839 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3841 struct item_list_3 items[2];
3842 unsigned short dvi_iosb[4];
3843 unsigned long devchar;
3844 unsigned long devclass;
3847 /* Very simple check to guess if sys$command is a decterm? */
3848 /* First see if the DECW$DISPLAY: device exists */
3850 items[0].code = DVI$_DEVCHAR;
3851 items[0].bufadr = &devchar;
3852 items[0].retadr = NULL;
3856 status = sys$getdviw
3857 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3859 if ($VMS_STATUS_SUCCESS(status)) {
3860 status = dvi_iosb[0];
3863 if (!$VMS_STATUS_SUCCESS(status)) {
3864 SETERRNO(EVMSERR, status);
3868 /* If it does, then for now assume that we are on a workstation */
3869 /* Now verify that SYS$COMMAND is a terminal */
3870 /* for creating the debugger DECTerm */
3873 items[0].code = DVI$_DEVCLASS;
3874 items[0].bufadr = &devclass;
3875 items[0].retadr = NULL;
3879 status = sys$getdviw
3880 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3882 if ($VMS_STATUS_SUCCESS(status)) {
3883 status = dvi_iosb[0];
3886 if (!$VMS_STATUS_SUCCESS(status)) {
3887 SETERRNO(EVMSERR, status);
3891 if (devclass == DC$_TERM) {
3898 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3899 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3904 char device_name[65];
3905 unsigned short device_name_len;
3906 struct dsc$descriptor_s customization_dsc;
3907 struct dsc$descriptor_s device_name_dsc;
3909 char customization[200];
3913 unsigned short p_chan;
3915 unsigned short iosb[4];
3916 const char * cust_str =
3917 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3918 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3919 DSC$K_CLASS_S, mbx1};
3921 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3922 /*---------------------------------------*/
3923 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3926 /* Make sure that this is from the Perl debugger */
3927 ret_char = strstr(cmd," xterm ");
3928 if (ret_char == NULL)
3930 cptr = ret_char + 7;
3931 ret_char = strstr(cmd,"tty");
3932 if (ret_char == NULL)
3934 ret_char = strstr(cmd,"sleep");
3935 if (ret_char == NULL)
3938 if (decw_term_port == 0) {
3939 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3940 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3941 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3943 status = lib$find_image_symbol
3945 &decw_term_port_dsc,
3946 (void *)&decw_term_port,
3950 /* Try again with the other image name */
3951 if (!$VMS_STATUS_SUCCESS(status)) {
3953 status = lib$find_image_symbol
3955 &decw_term_port_dsc,
3956 (void *)&decw_term_port,
3965 /* No decw$term_port, give it up */
3966 if (!$VMS_STATUS_SUCCESS(status))
3969 /* Are we on a workstation? */
3970 /* to do: capture the rows / columns and pass their properties */
3971 ret_stat = vms_is_syscommand_xterm();
3975 /* Make the title: */
3976 ret_char = strstr(cptr,"-title");
3977 if (ret_char != NULL) {
3978 while ((*cptr != 0) && (*cptr != '\"')) {
3984 while ((*cptr != 0) && (*cptr != '\"')) {
3997 strcpy(title,"Perl Debug DECTerm");
3999 sprintf(customization, cust_str, title);
4001 customization_dsc.dsc$a_pointer = customization;
4002 customization_dsc.dsc$w_length = strlen(customization);
4003 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4004 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4006 device_name_dsc.dsc$a_pointer = device_name;
4007 device_name_dsc.dsc$w_length = sizeof device_name -1;
4008 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4009 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4011 device_name_len = 0;
4013 /* Try to create the window */
4014 status = (*decw_term_port)
4023 if (!$VMS_STATUS_SUCCESS(status)) {
4024 SETERRNO(EVMSERR, status);
4028 device_name[device_name_len] = '\0';
4030 /* Need to set this up to look like a pipe for cleanup */
4032 status = lib$get_vm(&n, &info);
4033 if (!$VMS_STATUS_SUCCESS(status)) {
4034 SETERRNO(ENOMEM, status);
4040 info->completion = 0;
4041 info->closing = FALSE;
4048 info->in_done = TRUE;
4049 info->out_done = TRUE;
4050 info->err_done = TRUE;
4052 /* Assign a channel on this so that it will persist, and not login */
4053 /* We stash this channel in the info structure for reference. */
4054 /* The created xterm self destructs when the last channel is removed */
4055 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4056 /* So leave this assigned. */
4057 device_name_dsc.dsc$w_length = device_name_len;
4058 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4059 if (!$VMS_STATUS_SUCCESS(status)) {
4060 SETERRNO(EVMSERR, status);
4063 info->xchan_valid = 1;
4065 /* Now create a mailbox to be read by the application */
4067 create_mbx(&p_chan, &d_mbx1);
4069 /* write the name of the created terminal to the mailbox */
4070 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4071 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4073 if (!$VMS_STATUS_SUCCESS(status)) {
4074 SETERRNO(EVMSERR, status);
4078 info->fp = PerlIO_open(mbx1, mode);
4080 /* Done with this channel */
4083 /* If any errors, then clean up */
4086 _ckvmssts_noperl(lib$free_vm(&n, &info));
4094 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4097 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4099 static int handler_set_up = FALSE;
4101 unsigned long int sts, flags = CLI$M_NOWAIT;
4102 /* The use of a GLOBAL table (as was done previously) rendered
4103 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4104 * environment. Hence we've switched to LOCAL symbol table.
4106 unsigned int table = LIB$K_CLI_LOCAL_SYM;
4108 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4109 char *in, *out, *err, mbx[512];
4111 char tfilebuf[NAM$C_MAXRSS+1];
4113 char cmd_sym_name[20];
4114 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4115 DSC$K_CLASS_S, symbol};
4116 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4118 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4119 DSC$K_CLASS_S, cmd_sym_name};
4120 struct dsc$descriptor_s *vmscmd;
4121 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4122 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4123 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4125 /* Check here for Xterm create request. This means looking for
4126 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4127 * is possible to create an xterm.
4129 if (*in_mode == 'r') {
4132 #if defined(PERL_IMPLICIT_CONTEXT)
4133 /* Can not fork an xterm with a NULL context */
4134 /* This probably could never happen */
4138 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4139 if (xterm_fd != NULL)
4143 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4145 /* once-per-program initialization...
4146 note that the SETAST calls and the dual test of pipe_ef
4147 makes sure that only the FIRST thread through here does
4148 the initialization...all other threads wait until it's
4151 Yeah, uglier than a pthread call, it's got all the stuff inline
4152 rather than in a separate routine.
4156 _ckvmssts_noperl(sys$setast(0));
4158 unsigned long int pidcode = JPI$_PID;
4159 $DESCRIPTOR(d_delay, RETRY_DELAY);
4160 _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4161 _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4162 _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4164 if (!handler_set_up) {
4165 _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4166 handler_set_up = TRUE;
4168 _ckvmssts_noperl(sys$setast(1));
4171 /* see if we can find a VMSPIPE.COM */
4174 vmspipe = find_vmspipe(aTHX);
4176 vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4177 } else { /* uh, oh...we're in tempfile hell */
4178 tpipe = vmspipe_tempfile(aTHX);
4179 if (!tpipe) { /* a fish popular in Boston */
4180 if (ckWARN(WARN_PIPE)) {
4181 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4185 fgetname(tpipe,tfilebuf+1,1);
4186 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4188 vmspipedsc.dsc$a_pointer = tfilebuf;
4190 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4193 case RMS$_FNF: case RMS$_DNF:
4194 set_errno(ENOENT); break;
4196 set_errno(ENOTDIR); break;
4198 set_errno(ENODEV); break;
4200 set_errno(EACCES); break;
4202 set_errno(EINVAL); break;
4203 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4204 set_errno(E2BIG); break;
4205 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4206 _ckvmssts_noperl(sts); /* fall through */
4207 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4210 set_vaxc_errno(sts);
4211 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4212 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4218 _ckvmssts_noperl(lib$get_vm(&n, &info));
4220 my_strlcpy(mode, in_mode, sizeof(mode));
4223 info->completion = 0;
4224 info->closing = FALSE;
4231 info->in_done = TRUE;
4232 info->out_done = TRUE;
4233 info->err_done = TRUE;
4235 info->xchan_valid = 0;
4237 in = (char *)PerlMem_malloc(VMS_MAXRSS);
4238 if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4239 out = (char *)PerlMem_malloc(VMS_MAXRSS);
4240 if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4241 err = (char *)PerlMem_malloc(VMS_MAXRSS);
4242 if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4244 in[0] = out[0] = err[0] = '\0';
4246 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4250 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4255 if (*mode == 'r') { /* piping from subroutine */
4257 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4259 info->out->pipe_done = &info->out_done;
4260 info->out_done = FALSE;
4261 info->out->info = info;
4263 if (!info->useFILE) {
4264 info->fp = PerlIO_open(mbx, mode);
4266 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4267 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4270 if (!info->fp && info->out) {
4271 sys$cancel(info->out->chan_out);
4273 while (!info->out_done) {
4275 _ckvmssts_noperl(sys$setast(0));
4276 done = info->out_done;
4277 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4278 _ckvmssts_noperl(sys$setast(1));
4279 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4282 if (info->out->buf) {
4283 n = info->out->bufsize * sizeof(char);
4284 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4287 _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4289 _ckvmssts_noperl(lib$free_vm(&n, &info));
4294 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4296 info->err->pipe_done = &info->err_done;
4297 info->err_done = FALSE;
4298 info->err->info = info;
4301 } else if (*mode == 'w') { /* piping to subroutine */
4303 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4305 info->out->pipe_done = &info->out_done;
4306 info->out_done = FALSE;
4307 info->out->info = info;
4310 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4312 info->err->pipe_done = &info->err_done;
4313 info->err_done = FALSE;
4314 info->err->info = info;
4317 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4318 if (!info->useFILE) {
4319 info->fp = PerlIO_open(mbx, mode);
4321 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4322 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4326 info->in->pipe_done = &info->in_done;
4327 info->in_done = FALSE;
4328 info->in->info = info;
4332 if (!info->fp && info->in) {
4334 _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4335 0, 0, 0, 0, 0, 0, 0, 0));
4337 while (!info->in_done) {
4339 _ckvmssts_noperl(sys$setast(0));
4340 done = info->in_done;
4341 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4342 _ckvmssts_noperl(sys$setast(1));
4343 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4346 if (info->in->buf) {
4347 n = info->in->bufsize * sizeof(char);
4348 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4351 _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4353 _ckvmssts_noperl(lib$free_vm(&n, &info));
4359 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4360 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4362 info->out->pipe_done = &info->out_done;
4363 info->out_done = FALSE;
4364 info->out->info = info;
4367 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4369 info->err->pipe_done = &info->err_done;
4370 info->err_done = FALSE;
4371 info->err->info = info;
4375 d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4376 _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4378 d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4379 _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4381 d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4382 _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4384 /* Done with the names for the pipes */
4389 p = vmscmd->dsc$a_pointer;
4390 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4391 if (*p == '$') p++; /* remove leading $ */
4392 while (*p == ' ' || *p == '\t') p++;
4394 for (j = 0; j < 4; j++) {
4395 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4396 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4398 d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4399 _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4401 if (strlen(p) > MAX_DCL_SYMBOL) {
4402 p += MAX_DCL_SYMBOL;
4407 _ckvmssts_noperl(sys$setast(0));
4408 info->next=open_pipes; /* prepend to list */
4410 _ckvmssts_noperl(sys$setast(1));
4411 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4412 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4413 * have SYS$COMMAND if we need it.
4415 _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4416 0, &info->pid, &info->completion,
4417 0, popen_completion_ast,info,0,0,0));
4419 /* if we were using a tempfile, close it now */
4421 if (tpipe) fclose(tpipe);
4423 /* once the subprocess is spawned, it has copied the symbols and
4424 we can get rid of ours */
4426 for (j = 0; j < 4; j++) {
4427 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4428 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4429 _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4431 _ckvmssts_noperl(lib$delete_symbol(&d_sym_in, &table));
4432 _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4433 _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4434 vms_execfree(vmscmd);
4436 #ifdef PERL_IMPLICIT_CONTEXT
4439 PL_forkprocess = info->pid;
4446 _ckvmssts_noperl(sys$setast(0));
4448 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4449 _ckvmssts_noperl(sys$setast(1));
4450 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4452 *psts = info->completion;
4453 /* Caller thinks it is open and tries to close it. */
4454 /* This causes some problems, as it changes the error status */
4455 /* my_pclose(info->fp); */
4457 /* If we did not have a file pointer open, then we have to */
4458 /* clean up here or eventually we will run out of something */
4460 if (info->fp == NULL) {
4461 my_pclose_pinfo(aTHX_ info);
4469 } /* end of safe_popen */
4472 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4474 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4478 TAINT_PROPER("popen");
4479 PERL_FLUSHALL_FOR_CHILD;
4480 return safe_popen(aTHX_ cmd,mode,&sts);
4486 /* Routine to close and cleanup a pipe info structure */
4488 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4490 unsigned long int retsts;
4494 /* If we were writing to a subprocess, insure that someone reading from
4495 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4496 * produce an EOF record in the mailbox.
4498 * well, at least sometimes it *does*, so we have to watch out for
4499 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4503 #if defined(USE_ITHREADS)
4507 && PL_perlio_fd_refcnt
4510 PerlIO_flush(info->fp);
4512 fflush((FILE *)info->fp);
4515 _ckvmssts(sys$setast(0));
4516 info->closing = TRUE;
4517 done = info->done && info->in_done && info->out_done && info->err_done;
4518 /* hanging on write to Perl's input? cancel it */
4519 if (info->mode == 'r' && info->out && !info->out_done) {
4520 if (info->out->chan_out) {
4521 _ckvmssts(sys$cancel(info->out->chan_out));
4522 if (!info->out->chan_in) { /* EOF generation, need AST */
4523 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4527 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4528 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4530 _ckvmssts(sys$setast(1));
4533 #if defined(USE_ITHREADS)
4537 && PL_perlio_fd_refcnt
4540 PerlIO_close(info->fp);
4542 fclose((FILE *)info->fp);
4545 we have to wait until subprocess completes, but ALSO wait until all
4546 the i/o completes...otherwise we'll be freeing the "info" structure
4547 that the i/o ASTs could still be using...
4551 _ckvmssts(sys$setast(0));
4552 done = info->done && info->in_done && info->out_done && info->err_done;
4553 if (!done) _ckvmssts(sys$clref(pipe_ef));
4554 _ckvmssts(sys$setast(1));
4555 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4557 retsts = info->completion;
4559 /* remove from list of open pipes */
4560 _ckvmssts(sys$setast(0));
4562 for (next = open_pipes; next != NULL; last = next, next = next->next) {
4568 last->next = info->next;
4570 open_pipes = info->next;
4571 _ckvmssts(sys$setast(1));
4573 /* free buffers and structures */
4576 if (info->in->buf) {
4577 n = info->in->bufsize * sizeof(char);
4578 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4581 _ckvmssts(lib$free_vm(&n, &info->in));
4584 if (info->out->buf) {
4585 n = info->out->bufsize * sizeof(char);
4586 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4589 _ckvmssts(lib$free_vm(&n, &info->out));
4592 if (info->err->buf) {
4593 n = info->err->bufsize * sizeof(char);
4594 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4597 _ckvmssts(lib$free_vm(&n, &info->err));
4600 _ckvmssts(lib$free_vm(&n, &info));
4606 /*{{{ I32 my_pclose(PerlIO *fp)*/
4607 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4609 pInfo info, last = NULL;
4612 /* Fixme - need ast and mutex protection here */
4613 for (info = open_pipes; info != NULL; last = info, info = info->next)
4614 if (info->fp == fp) break;
4616 if (info == NULL) { /* no such pipe open */
4617 set_errno(ECHILD); /* quoth POSIX */
4618 set_vaxc_errno(SS$_NONEXPR);
4622 ret_status = my_pclose_pinfo(aTHX_ info);
4626 } /* end of my_pclose() */
4628 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4629 /* Roll our own prototype because we want this regardless of whether
4630 * _VMS_WAIT is defined.
4636 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4642 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4643 created with popen(); otherwise partially emulate waitpid() unless
4644 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4645 Also check processes not considered by the CRTL waitpid().
4647 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4649 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4656 if (statusp) *statusp = 0;
4658 for (info = open_pipes; info != NULL; info = info->next)
4659 if (info->pid == pid) break;
4661 if (info != NULL) { /* we know about this child */
4662 while (!info->done) {
4663 _ckvmssts(sys$setast(0));
4665 if (!done) _ckvmssts(sys$clref(pipe_ef));
4666 _ckvmssts(sys$setast(1));
4667 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4670 if (statusp) *statusp = info->completion;
4674 /* child that already terminated? */
4676 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4677 if (closed_list[j].pid == pid) {
4678 if (statusp) *statusp = closed_list[j].completion;
4683 /* fall through if this child is not one of our own pipe children */
4685 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4687 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4688 * in 7.2 did we get a version that fills in the VMS completion
4689 * status as Perl has always tried to do.
4692 sts = __vms_waitpid( pid, statusp, flags );
4694 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4697 /* If the real waitpid tells us the child does not exist, we
4698 * fall through here to implement waiting for a child that
4699 * was created by some means other than exec() (say, spawned
4700 * from DCL) or to wait for a process that is not a subprocess
4701 * of the current process.
4704 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4707 $DESCRIPTOR(intdsc,"0 00:00:01");
4708 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4709 unsigned long int pidcode = JPI$_PID, mypid;
4710 unsigned long int interval[2];
4711 unsigned int jpi_iosb[2];
4712 struct itmlst_3 jpilist[2] = {
4713 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4718 /* Sorry folks, we don't presently implement rooting around for
4719 the first child we can find, and we definitely don't want to
4720 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4726 /* Get the owner of the child so I can warn if it's not mine. If the
4727 * process doesn't exist or I don't have the privs to look at it,
4728 * I can go home early.
4730 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4731 if (sts & 1) sts = jpi_iosb[0];
4743 set_vaxc_errno(sts);
4747 if (ckWARN(WARN_EXEC)) {
4748 /* remind folks they are asking for non-standard waitpid behavior */
4749 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4750 if (ownerpid != mypid)
4751 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4752 "waitpid: process %x is not a child of process %x",
4756 /* simply check on it once a second until it's not there anymore. */
4758 _ckvmssts(sys$bintim(&intdsc,interval));
4759 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4760 _ckvmssts(sys$schdwk(0,0,interval,0));
4761 _ckvmssts(sys$hiber());
4763 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4768 } /* end of waitpid() */
4773 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4775 my_gconvert(double val, int ndig, int trail, char *buf)
4777 static char __gcvtbuf[DBL_DIG+1];
4780 loc = buf ? buf : __gcvtbuf;
4783 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4784 return gcvt(val,ndig,loc);
4787 loc[0] = '0'; loc[1] = '\0';
4794 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4795 static int rms_free_search_context(struct FAB * fab)
4799 nam = fab->fab$l_nam;
4800 nam->nam$b_nop |= NAM$M_SYNCHK;
4801 nam->nam$l_rlf = NULL;
4803 return sys$parse(fab, NULL, NULL);
4806 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4807 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4808 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4809 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4810 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4811 #define rms_nam_esll(nam) nam.nam$b_esl
4812 #define rms_nam_esl(nam) nam.nam$b_esl
4813 #define rms_nam_name(nam) nam.nam$l_name
4814 #define rms_nam_namel(nam) nam.nam$l_name
4815 #define rms_nam_type(nam) nam.nam$l_type
4816 #define rms_nam_typel(nam) nam.nam$l_type
4817 #define rms_nam_ver(nam) nam.nam$l_ver
4818 #define rms_nam_verl(nam) nam.nam$l_ver
4819 #define rms_nam_rsll(nam) nam.nam$b_rsl
4820 #define rms_nam_rsl(nam) nam.nam$b_rsl
4821 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4822 #define rms_set_fna(fab, nam, name, size) \
4823 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4824 #define rms_get_fna(fab, nam) fab.fab$l_fna
4825 #define rms_set_dna(fab, nam, name, size) \
4826 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4827 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4828 #define rms_set_esa(nam, name, size) \
4829 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4830 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4831 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4832 #define rms_set_rsa(nam, name, size) \
4833 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4834 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4835 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4836 #define rms_nam_name_type_l_size(nam) \
4837 (nam.nam$b_name + nam.nam$b_type)
4839 static int rms_free_search_context(struct FAB * fab)
4843 nam = fab->fab$l_naml;
4844 nam->naml$b_nop |= NAM$M_SYNCHK;
4845 nam->naml$l_rlf = NULL;
4846 nam->naml$l_long_defname_size = 0;
4849 return sys$parse(fab, NULL, NULL);
4852 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4853 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4854 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4855 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4856 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4857 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4858 #define rms_nam_esl(nam) nam.naml$b_esl
4859 #define rms_nam_name(nam) nam.naml$l_name
4860 #define rms_nam_namel(nam) nam.naml$l_long_name
4861 #define rms_nam_type(nam) nam.naml$l_type
4862 #define rms_nam_typel(nam) nam.naml$l_long_type
4863 #define rms_nam_ver(nam) nam.naml$l_ver
4864 #define rms_nam_verl(nam) nam.naml$l_long_ver
4865 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4866 #define rms_nam_rsl(nam) nam.naml$b_rsl
4867 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4868 #define rms_set_fna(fab, nam, name, size) \
4869 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4870 nam.naml$l_long_filename_size = size; \
4871 nam.naml$l_long_filename = name;}
4872 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4873 #define rms_set_dna(fab, nam, name, size) \
4874 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4875 nam.naml$l_long_defname_size = size; \
4876 nam.naml$l_long_defname = name; }
4877 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4878 #define rms_set_esa(nam, name, size) \
4879 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4880 nam.naml$l_long_expand_alloc = size; \
4881 nam.naml$l_long_expand = name; }
4882 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4883 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4884 nam.naml$l_long_expand = l_name; \
4885 nam.naml$l_long_expand_alloc = l_size; }
4886 #define rms_set_rsa(nam, name, size) \
4887 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4888 nam.naml$l_long_result = name; \
4889 nam.naml$l_long_result_alloc = size; }
4890 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4891 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4892 nam.naml$l_long_result = l_name; \
4893 nam.naml$l_long_result_alloc = l_size; }
4894 #define rms_nam_name_type_l_size(nam) \
4895 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4900 * The CRTL for 8.3 and later can create symbolic links in any mode,
4901 * however in 8.3 the unlink/remove/delete routines will only properly handle
4902 * them if one of the PCP modes is active.
4904 static int rms_erase(const char * vmsname)
4907 struct FAB myfab = cc$rms_fab;
4908 rms_setup_nam(mynam);
4910 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4911 rms_bind_fab_nam(myfab, mynam);
4913 #ifdef NAML$M_OPEN_SPECIAL
4914 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4917 status = sys$erase(&myfab, 0, 0);
4924 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4925 const struct dsc$descriptor_s * vms_dst_dsc,
4926 unsigned long flags)
4928 /* VMS and UNIX handle file permissions differently and the
4929 * the same ACL trick may be needed for renaming files,
4930 * especially if they are directories.
4933 /* todo: get kill_file and rename to share common code */
4934 /* I can not find online documentation for $change_acl
4935 * it appears to be replaced by $set_security some time ago */
4937 const unsigned int access_mode = 0;
4938 $DESCRIPTOR(obj_file_dsc,"FILE");
4941 unsigned long int jpicode = JPI$_UIC;
4942 int aclsts, fndsts, rnsts = -1;
4943 unsigned int ctx = 0;
4944 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4945 struct dsc$descriptor_s * clean_dsc;
4948 unsigned char myace$b_length;
4949 unsigned char myace$b_type;
4950 unsigned short int myace$w_flags;
4951 unsigned long int myace$l_access;
4952 unsigned long int myace$l_ident;
4953 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4954 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4956 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4959 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4960 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4962 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4963 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4967 /* Expand the input spec using RMS, since we do not want to put
4968 * ACLs on the target of a symbolic link */
4969 vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
4970 if (vmsname == NULL)
4973 rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4975 PERL_RMSEXPAND_M_SYMLINK);
4977 PerlMem_free(vmsname);
4981 /* So we get our own UIC to use as a rights identifier,
4982 * and the insert an ACE at the head of the ACL which allows us
4983 * to delete the file.
4985 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4987 fildsc.dsc$w_length = strlen(vmsname);
4988 fildsc.dsc$a_pointer = vmsname;
4990 newace.myace$l_ident = oldace.myace$l_ident;
4993 /* Grab any existing ACEs with this identifier in case we fail */
4994 clean_dsc = &fildsc;
4995 aclsts = fndsts = sys$get_security(&obj_file_dsc,
5003 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
5004 /* Add the new ACE . . . */
5006 /* if the sys$get_security succeeded, then ctx is valid, and the
5007 * object/file descriptors will be ignored. But otherwise they
5010 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5011 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5012 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5014 set_vaxc_errno(aclsts);
5015 PerlMem_free(vmsname);
5019 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5022 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5024 if ($VMS_STATUS_SUCCESS(rnsts)) {
5025 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5028 /* Put things back the way they were. */
5030 aclsts = sys$get_security(&obj_file_dsc,
5038 if ($VMS_STATUS_SUCCESS(aclsts)) {
5042 if (!$VMS_STATUS_SUCCESS(fndsts))
5043 sec_flags = OSS$M_RELCTX;
5045 /* Get rid of the new ACE */
5046 aclsts = sys$set_security(NULL, NULL, NULL,
5047 sec_flags, dellst, &ctx, &access_mode);
5049 /* If there was an old ACE, put it back */
5050 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5051 addlst[0].bufadr = &oldace;
5052 aclsts = sys$set_security(NULL, NULL, NULL,
5053 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5054 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5056 set_vaxc_errno(aclsts);
5062 /* Try to clear the lock on the ACL list */
5063 aclsts2 = sys$set_security(NULL, NULL, NULL,
5064 OSS$M_RELCTX, NULL, &ctx, &access_mode);
5066 /* Rename errors are most important */
5067 if (!$VMS_STATUS_SUCCESS(rnsts))
5070 set_vaxc_errno(aclsts);
5075 if (aclsts != SS$_ACLEMPTY)
5082 PerlMem_free(vmsname);
5087 /*{{{int rename(const char *, const char * */
5088 /* Not exactly what X/Open says to do, but doing it absolutely right
5089 * and efficiently would require a lot more work. This should be close
5090 * enough to pass all but the most strict X/Open compliance test.
5093 Perl_rename(pTHX_ const char *src, const char * dst)
5102 /* Validate the source file */
5103 src_sts = flex_lstat(src, &src_st);
5106 /* No source file or other problem */
5109 if (src_st.st_devnam[0] == 0) {
5110 /* This may be possible so fail if it is seen. */
5115 dst_sts = flex_lstat(dst, &dst_st);
5118 if (dst_st.st_dev != src_st.st_dev) {
5119 /* Must be on the same device */
5124 /* VMS_INO_T_COMPARE is true if the inodes are different
5125 * to match the output of memcmp
5128 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5129 /* That was easy, the files are the same! */
5133 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5134 /* If source is a directory, so must be dest */
5142 if ((dst_sts == 0) &&
5143 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5145 /* We have issues here if vms_unlink_all_versions is set
5146 * If the destination exists, and is not a directory, then
5147 * we must delete in advance.
5149 * If the src is a directory, then we must always pre-delete
5152 * If we successfully delete the dst in advance, and the rename fails
5153 * X/Open requires that errno be EIO.
5157 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5159 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5160 S_ISDIR(dst_st.st_mode));
5162 /* Need to delete all versions ? */
5163 if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5166 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5167 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5172 /* Make sure that we do not loop forever */
5184 /* We killed the destination, so only errno now is EIO */
5189 /* Originally the idea was to call the CRTL rename() and only
5190 * try the lib$rename_file if it failed.
5191 * It turns out that there are too many variants in what the
5192 * the CRTL rename might do, so only use lib$rename_file
5197 /* Is the source and dest both in VMS format */
5198 /* if the source is a directory, then need to fileify */
5199 /* and dest must be a directory or non-existent. */
5204 unsigned long flags;
5205 struct dsc$descriptor_s old_file_dsc;
5206 struct dsc$descriptor_s new_file_dsc;
5208 /* We need to modify the src and dst depending
5209 * on if one or more of them are directories.
5212 vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
5213 if (vms_dst == NULL)
5214 _ckvmssts_noperl(SS$_INSFMEM);
5216 if (S_ISDIR(src_st.st_mode)) {
5218 char * vms_dir_file;
5220 vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
5221 if (vms_dir_file == NULL)
5222 _ckvmssts_noperl(SS$_INSFMEM);
5224 /* If the dest is a directory, we must remove it */
5227 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5229 PerlMem_free(vms_dst);
5237 /* The dest must be a VMS file specification */
5238 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5239 if (ret_str == NULL) {
5240 PerlMem_free(vms_dst);
5245 /* The source must be a file specification */
5246 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5247 if (ret_str == NULL) {
5248 PerlMem_free(vms_dst);
5249 PerlMem_free(vms_dir_file);
5253 PerlMem_free(vms_dst);
5254 vms_dst = vms_dir_file;
5257 /* File to file or file to new dir */
5259 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5260 /* VMS pathify a dir target */
5261 ret_str = int_tovmspath(dst, vms_dst, NULL);
5262 if (ret_str == NULL) {
5263 PerlMem_free(vms_dst);
5268 char * v_spec, * r_spec, * d_spec, * n_spec;
5269 char * e_spec, * vs_spec;
5270 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5272 /* fileify a target VMS file specification */
5273 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5274 if (ret_str == NULL) {
5275 PerlMem_free(vms_dst);
5280 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5281 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5282 &e_len, &vs_spec, &vs_len);
5285 /* Get rid of the version */
5289 /* Need to specify a '.' so that the extension */
5290 /* is not inherited */
5291 strcat(vms_dst,".");
5297 old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5298 old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5299 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5300 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5302 new_file_dsc.dsc$a_pointer = vms_dst;
5303 new_file_dsc.dsc$w_length = strlen(vms_dst);
5304 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5305 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5308 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5309 flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5312 sts = lib$rename_file(&old_file_dsc,
5316 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5317 if (!$VMS_STATUS_SUCCESS(sts)) {
5319 /* We could have failed because VMS style permissions do not
5320 * permit renames that UNIX will allow. Just like the hack
5323 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5326 PerlMem_free(vms_dst);
5327 if (!$VMS_STATUS_SUCCESS(sts)) {
5334 if (vms_unlink_all_versions) {
5335 /* Now get rid of any previous versions of the source file that
5341 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5342 S_ISDIR(src_st.st_mode));
5343 while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5344 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5345 S_ISDIR(src_st.st_mode));
5350 /* Make sure that we do not loop forever */
5359 /* We deleted the destination, so must force the error to be EIO */
5360 if ((retval != 0) && (pre_delete != 0))
5368 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5369 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5370 * to expand file specification. Allows for a single default file
5371 * specification and a simple mask of options. If outbuf is non-NULL,
5372 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5373 * the resultant file specification is placed. If outbuf is NULL, the
5374 * resultant file specification is placed into a static buffer.
5375 * The third argument, if non-NULL, is taken to be a default file
5376 * specification string. The fourth argument is unused at present.
5377 * rmesexpand() returns the address of the resultant string if
5378 * successful, and NULL on error.
5380 * New functionality for previously unused opts value:
5381 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5382 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5383 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5384 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5386 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5390 (const char *filespec,
5392 const char *defspec,
5398 const char * in_spec;
5400 const char * def_spec;
5401 char * vmsfspec, *vmsdefspec;
5405 struct FAB myfab = cc$rms_fab;
5406 rms_setup_nam(mynam);
5408 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5411 /* temp hack until UTF8 is actually implemented */
5412 if (fs_utf8 != NULL)
5415 if (!filespec || !*filespec) {
5416 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5426 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5427 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5428 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5430 /* If this is a UNIX file spec, convert it to VMS */
5431 sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5432 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5433 &e_len, &vs_spec, &vs_len);
5438 vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5439 if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5440 ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5441 if (ret_spec == NULL) {
5442 PerlMem_free(vmsfspec);
5445 in_spec = (const char *)vmsfspec;
5447 /* Unless we are forcing to VMS format, a UNIX input means
5448 * UNIX output, and that requires long names to be used
5450 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5451 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5452 opts |= PERL_RMSEXPAND_M_LONG;
5462 rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5463 rms_bind_fab_nam(myfab, mynam);
5465 /* Process the default file specification if present */
5467 if (defspec && *defspec) {
5469 t_isunix = is_unix_filespec(defspec);
5471 vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5472 if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5473 ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5475 if (ret_spec == NULL) {
5476 /* Clean up and bail */
5477 PerlMem_free(vmsdefspec);
5478 if (vmsfspec != NULL)
5479 PerlMem_free(vmsfspec);
5482 def_spec = (const char *)vmsdefspec;
5484 rms_set_dna(myfab, mynam,
5485 (char *)def_spec, strlen(def_spec)); /* cast ok */
5488 /* Now we need the expansion buffers */
5489 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
5490 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5491 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5492 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
5493 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5495 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5497 /* If a NAML block is used RMS always writes to the long and short
5498 * addresses unless you suppress the short name.
5500 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5501 outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
5502 if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5504 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5506 #ifdef NAM$M_NO_SHORT_UPCASE
5507 if (decc_efs_case_preserve)
5508 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5511 /* We may not want to follow symbolic links */
5512 #ifdef NAML$M_OPEN_SPECIAL
5513 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5514 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5517 /* First attempt to parse as an existing file */
5518 retsts = sys$parse(&myfab,0,0);
5519 if (!(retsts & STS$K_SUCCESS)) {
5521 /* Could not find the file, try as syntax only if error is not fatal */
5522 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5523 if (retsts == RMS$_DNF ||
5524 retsts == RMS$_DIR ||
5525 retsts == RMS$_DEV ||
5526 retsts == RMS$_PRV) {
5527 retsts = sys$parse(&myfab,0,0);
5528 if (retsts & STS$K_SUCCESS) goto int_expanded;
5531 /* Still could not parse the file specification */
5532 /*----------------------------------------------*/
5533 sts = rms_free_search_context(&myfab); /* Free search context */
5534 if (vmsdefspec != NULL)
5535 PerlMem_free(vmsdefspec);
5536 if (vmsfspec != NULL)
5537 PerlMem_free(vmsfspec);
5538 if (outbufl != NULL)
5539 PerlMem_free(outbufl);
5543 set_vaxc_errno(retsts);
5544 if (retsts == RMS$_PRV) set_errno(EACCES);
5545 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5546 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5547 else set_errno(EVMSERR);
5550 retsts = sys$search(&myfab,0,0);
5551 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5552 sts = rms_free_search_context(&myfab); /* Free search context */
5553 if (vmsdefspec != NULL)
5554 PerlMem_free(vmsdefspec);
5555 if (vmsfspec != NULL)
5556 PerlMem_free(vmsfspec);
5557 if (outbufl != NULL)
5558 PerlMem_free(outbufl);
5562 set_vaxc_errno(retsts);
5563 if (retsts == RMS$_PRV) set_errno(EACCES);
5564 else set_errno(EVMSERR);
5568 /* If the input filespec contained any lowercase characters,
5569 * downcase the result for compatibility with Unix-minded code. */
5571 if (!decc_efs_case_preserve) {
5573 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5574 if (islower(*tbuf)) { haslower = 1; break; }
5577 /* Is a long or a short name expected */
5578 /*------------------------------------*/
5580 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5581 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5582 if (rms_nam_rsll(mynam)) {
5584 speclen = rms_nam_rsll(mynam);
5587 spec_buf = esal; /* Not esa */
5588 speclen = rms_nam_esll(mynam);
5593 if (rms_nam_rsl(mynam)) {
5595 speclen = rms_nam_rsl(mynam);
5598 spec_buf = esa; /* Not esal */
5599 speclen = rms_nam_esl(mynam);
5601 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5604 spec_buf[speclen] = '\0';
5606 /* Trim off null fields added by $PARSE
5607 * If type > 1 char, must have been specified in original or default spec
5608 * (not true for version; $SEARCH may have added version of existing file).
5610 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5611 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5612 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5613 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5616 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5617 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5619 if (trimver || trimtype) {
5620 if (defspec && *defspec) {
5621 char *defesal = NULL;
5622 char *defesa = NULL;
5623 defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5624 if (defesa != NULL) {
5625 struct FAB deffab = cc$rms_fab;
5626 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5627 defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5628 if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5630 rms_setup_nam(defnam);
5632 rms_bind_fab_nam(deffab, defnam);
5636 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5638 /* RMS needs the esa/esal as a work area if wildcards are involved */
5639 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5641 rms_clear_nam_nop(defnam);
5642 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5643 #ifdef NAM$M_NO_SHORT_UPCASE
5644 if (decc_efs_case_preserve)
5645 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5647 #ifdef NAML$M_OPEN_SPECIAL
5648 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5649 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5651 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5653 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5656 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5659 if (defesal != NULL)
5660 PerlMem_free(defesal);
5661 PerlMem_free(defesa);
5663 _ckvmssts_noperl(SS$_INSFMEM);
5667 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5668 if (*(rms_nam_verl(mynam)) != '\"')
5669 speclen = rms_nam_verl(mynam) - spec_buf;
5672 if (*(rms_nam_ver(mynam)) != '\"')
5673 speclen = rms_nam_ver(mynam) - spec_buf;
5677 /* If we didn't already trim version, copy down */
5678 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5679 if (speclen > rms_nam_verl(mynam) - spec_buf)
5681 (rms_nam_typel(mynam),
5682 rms_nam_verl(mynam),
5683 speclen - (rms_nam_verl(mynam) - spec_buf));
5684 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5687 if (speclen > rms_nam_ver(mynam) - spec_buf)
5689 (rms_nam_type(mynam),
5691 speclen - (rms_nam_ver(mynam) - spec_buf));
5692 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5697 /* Done with these copies of the input files */
5698 /*-------------------------------------------*/
5699 if (vmsfspec != NULL)
5700 PerlMem_free(vmsfspec);
5701 if (vmsdefspec != NULL)
5702 PerlMem_free(vmsdefspec);
5704 /* If we just had a directory spec on input, $PARSE "helpfully"
5705 * adds an empty name and type for us */
5706 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5707 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5708 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5709 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5710 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5711 speclen = rms_nam_namel(mynam) - spec_buf;
5716 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5717 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5718 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5719 speclen = rms_nam_name(mynam) - spec_buf;
5722 /* Posix format specifications must have matching quotes */
5723 if (speclen < (VMS_MAXRSS - 1)) {
5724 if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5725 if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5726 spec_buf[speclen] = '\"';
5731 spec_buf[speclen] = '\0';
5732 if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5734 /* Have we been working with an expanded, but not resultant, spec? */
5735 /* Also, convert back to Unix syntax if necessary. */
5739 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5740 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5741 rsl = rms_nam_rsll(mynam);
5745 rsl = rms_nam_rsl(mynam);
5748 /* rsl is not present, it means that spec_buf is either */
5749 /* esa or esal, and needs to be copied to outbuf */
5750 /* convert to Unix if desired */
5752 ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5754 /* VMS file specs are not in UTF-8 */
5755 if (fs_utf8 != NULL)
5757 my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5762 /* Now spec_buf is either outbuf or outbufl */
5763 /* We need the result into outbuf */
5765 /* If we need this in UNIX, then we need another buffer */
5766 /* to keep things in order */
5768 char * new_src = NULL;
5769 if (spec_buf == outbuf) {
5770 new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
5771 my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5775 ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5777 PerlMem_free(new_src);
5780 /* VMS file specs are not in UTF-8 */
5781 if (fs_utf8 != NULL)
5784 /* Copy the buffer if needed */
5785 if (outbuf != spec_buf)
5786 my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5792 /* Need to clean up the search context */
5793 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5794 sts = rms_free_search_context(&myfab); /* Free search context */
5796 /* Clean up the extra buffers */
5800 if (outbufl != NULL)
5801 PerlMem_free(outbufl);
5803 /* Return the result */
5807 /* Common simple case - Expand an already VMS spec */
5809 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5810 opts |= PERL_RMSEXPAND_M_VMS_IN;
5811 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5814 /* Common simple case - Expand to a VMS spec */
5816 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5817 opts |= PERL_RMSEXPAND_M_VMS;
5818 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5822 /* Entry point used by perl routines */
5825 (pTHX_ const char *filespec,
5828 const char *defspec,
5833 static char __rmsexpand_retbuf[VMS_MAXRSS];
5834 char * expanded, *ret_spec, *ret_buf;
5838 if (ret_buf == NULL) {
5840 Newx(expanded, VMS_MAXRSS, char);
5841 if (expanded == NULL)
5842 _ckvmssts(SS$_INSFMEM);
5845 ret_buf = __rmsexpand_retbuf;
5850 ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5851 opts, fs_utf8, dfs_utf8);
5853 if (ret_spec == NULL) {
5854 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5862 /* External entry points */
5863 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5864 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5865 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5866 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5867 char *Perl_rmsexpand_utf8
5868 (pTHX_ const char *spec, char *buf, const char *def,
5869 unsigned opt, int * fs_utf8, int * dfs_utf8)
5870 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5871 char *Perl_rmsexpand_utf8_ts
5872 (pTHX_ const char *spec, char *buf, const char *def,
5873 unsigned opt, int * fs_utf8, int * dfs_utf8)
5874 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5878 ** The following routines are provided to make life easier when
5879 ** converting among VMS-style and Unix-style directory specifications.
5880 ** All will take input specifications in either VMS or Unix syntax. On
5881 ** failure, all return NULL. If successful, the routines listed below
5882 ** return a pointer to a buffer containing the appropriately
5883 ** reformatted spec (and, therefore, subsequent calls to that routine
5884 ** will clobber the result), while the routines of the same names with
5885 ** a _ts suffix appended will return a pointer to a mallocd string
5886 ** containing the appropriately reformatted spec.
5887 ** In all cases, only explicit syntax is altered; no check is made that
5888 ** the resulting string is valid or that the directory in question
5891 ** fileify_dirspec() - convert a directory spec into the name of the
5892 ** directory file (i.e. what you can stat() to see if it's a dir).
5893 ** The style (VMS or Unix) of the result is the same as the style
5894 ** of the parameter passed in.
5895 ** pathify_dirspec() - convert a directory spec into a path (i.e.
5896 ** what you prepend to a filename to indicate what directory it's in).
5897 ** The style (VMS or Unix) of the result is the same as the style
5898 ** of the parameter passed in.
5899 ** tounixpath() - convert a directory spec into a Unix-style path.
5900 ** tovmspath() - convert a directory spec into a VMS-style path.
5901 ** tounixspec() - convert any file spec into a Unix-style file spec.
5902 ** tovmsspec() - convert any file spec into a VMS-style spec.
5903 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5905 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
5906 ** Permission is given to distribute this code as part of the Perl
5907 ** standard distribution under the terms of the GNU General Public
5908 ** License or the Perl Artistic License. Copies of each may be
5909 ** found in the Perl standard distribution.
5912 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5914 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5916 unsigned long int dirlen, retlen, hasfilename = 0;
5917 char *cp1, *cp2, *lastdir;
5918 char *trndir, *vmsdir;
5919 unsigned short int trnlnm_iter_count;
5921 if (utf8_fl != NULL)
5924 if (!dir || !*dir) {
5925 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5927 dirlen = strlen(dir);
5928 while (dirlen && dir[dirlen-1] == '/') --dirlen;
5929 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5930 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5937 if (dirlen > (VMS_MAXRSS - 1)) {
5938 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5941 trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5942 if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5943 if (!strpbrk(dir+1,"/]>:") &&
5944 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5945 strcpy(trndir,*dir == '/' ? dir + 1: dir);
5946 trnlnm_iter_count = 0;
5947 while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
5948 trnlnm_iter_count++;
5949 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5951 dirlen = strlen(trndir);
5954 memcpy(trndir, dir, dirlen);
5955 trndir[dirlen] = '\0';
5958 /* At this point we are done with *dir and use *trndir which is a
5959 * copy that can be modified. *dir must not be modified.
5962 /* If we were handed a rooted logical name or spec, treat it like a
5963 * simple directory, so that
5964 * $ Define myroot dev:[dir.]
5965 * ... do_fileify_dirspec("myroot",buf,1) ...
5966 * does something useful.
5968 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5969 trndir[--dirlen] = '\0';
5970 trndir[dirlen-1] = ']';
5972 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5973 trndir[--dirlen] = '\0';
5974 trndir[dirlen-1] = '>';
5977 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5978 /* If we've got an explicit filename, we can just shuffle the string. */
5979 if (*(cp1+1)) hasfilename = 1;
5980 /* Similarly, we can just back up a level if we've got multiple levels
5981 of explicit directories in a VMS spec which ends with directories. */
5983 for (cp2 = cp1; cp2 > trndir; cp2--) {
5985 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5986 /* fix-me, can not scan EFS file specs backward like this */
5987 *cp2 = *cp1; *cp1 = '\0';
5992 if (*cp2 == '[' || *cp2 == '<') break;
5997 vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5998 if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5999 cp1 = strpbrk(trndir,"]:>");
6000 if (hasfilename || !cp1) { /* filename present or not VMS */
6002 if (trndir[0] == '.') {
6003 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6004 PerlMem_free(trndir);
6005 PerlMem_free(vmsdir);
6006 return int_fileify_dirspec("[]", buf, NULL);
6008 else if (trndir[1] == '.' &&
6009 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6010 PerlMem_free(trndir);
6011 PerlMem_free(vmsdir);
6012 return int_fileify_dirspec("[-]", buf, NULL);
6015 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
6016 dirlen -= 1; /* to last element */
6017 lastdir = strrchr(trndir,'/');
6019 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6020 /* If we have "/." or "/..", VMSify it and let the VMS code
6021 * below expand it, rather than repeating the code to handle
6022 * relative components of a filespec here */
6024 if (*(cp1+2) == '.') cp1++;
6025 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6027 if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6028 PerlMem_free(trndir);
6029 PerlMem_free(vmsdir);
6032 if (strchr(vmsdir,'/') != NULL) {
6033 /* If int_tovmsspec() returned it, it must have VMS syntax
6034 * delimiters in it, so it's a mixed VMS/Unix spec. We take
6035 * the time to check this here only so we avoid a recursion
6036 * loop; otherwise, gigo.
6038 PerlMem_free(trndir);
6039 PerlMem_free(vmsdir);
6040 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
6043 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6044 PerlMem_free(trndir);
6045 PerlMem_free(vmsdir);
6048 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6049 PerlMem_free(trndir);
6050 PerlMem_free(vmsdir);
6054 } while ((cp1 = strstr(cp1,"/.")) != NULL);
6055 lastdir = strrchr(trndir,'/');
6057 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6059 /* Ditto for specs that end in an MFD -- let the VMS code
6060 * figure out whether it's a real device or a rooted logical. */
6062 /* This should not happen any more. Allowing the fake /000000
6063 * in a UNIX pathname causes all sorts of problems when trying
6064 * to run in UNIX emulation. So the VMS to UNIX conversions
6065 * now remove the fake /000000 directories.
6068 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6069 if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6070 PerlMem_free(trndir);
6071 PerlMem_free(vmsdir);
6074 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6075 PerlMem_free(trndir);
6076 PerlMem_free(vmsdir);
6079 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6080 PerlMem_free(trndir);
6081 PerlMem_free(vmsdir);
6086 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6087 !(lastdir = cp1 = strrchr(trndir,']')) &&
6088 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6090 cp2 = strrchr(cp1,'.');
6092 int e_len, vs_len = 0;
6095 cp3 = strchr(cp2,';');
6096 e_len = strlen(cp2);
6098 vs_len = strlen(cp3);
6099 e_len = e_len - vs_len;
6101 is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6103 if (!decc_efs_charset) {
6104 /* If this is not EFS, then not a directory */
6105 PerlMem_free(trndir);
6106 PerlMem_free(vmsdir);
6108 set_vaxc_errno(RMS$_DIR);
6112 /* Ok, here we have an issue, technically if a .dir shows */
6113 /* from inside a directory, then we should treat it as */
6114 /* xxx^.dir.dir. But we do not have that context at this */
6115 /* point unless this is totally restructured, so we remove */
6116 /* The .dir for now, and fix this better later */
6117 dirlen = cp2 - trndir;
6119 if (decc_efs_charset && !strchr(trndir,'/')) {
6120 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6121 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6123 for (; cp4 > cp1; cp4--) {
6125 if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6126 memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6137 retlen = dirlen + 6;
6138 memcpy(buf, trndir, dirlen);
6141 /* We've picked up everything up to the directory file name.
6142 Now just add the type and version, and we're set. */
6143 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6144 strcat(buf,".dir;1");
6146 strcat(buf,".DIR;1");
6147 PerlMem_free(trndir);
6148 PerlMem_free(vmsdir);
6151 else { /* VMS-style directory spec */
6153 char *esa, *esal, term, *cp;
6156 unsigned long int cmplen, haslower = 0;
6157 struct FAB dirfab = cc$rms_fab;
6158 rms_setup_nam(savnam);
6159 rms_setup_nam(dirnam);
6161 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
6162 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6164 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6165 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
6166 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6168 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6169 rms_bind_fab_nam(dirfab, dirnam);
6170 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6171 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6172 #ifdef NAM$M_NO_SHORT_UPCASE
6173 if (decc_efs_case_preserve)
6174 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6177 for (cp = trndir; *cp; cp++)
6178 if (islower(*cp)) { haslower = 1; break; }
6179 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6180 if ((dirfab.fab$l_sts == RMS$_DIR) ||
6181 (dirfab.fab$l_sts == RMS$_DNF) ||
6182 (dirfab.fab$l_sts == RMS$_PRV)) {
6183 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6184 sts = sys$parse(&dirfab);
6190 PerlMem_free(trndir);
6191 PerlMem_free(vmsdir);
6193 set_vaxc_errno(dirfab.fab$l_sts);
6199 /* Does the file really exist? */
6200 if (sys$search(&dirfab)& STS$K_SUCCESS) {
6201 /* Yes; fake the fnb bits so we'll check type below */
6202 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6204 else { /* No; just work with potential name */
6205 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6208 fab_sts = dirfab.fab$l_sts;
6209 sts = rms_free_search_context(&dirfab);
6213 PerlMem_free(trndir);
6214 PerlMem_free(vmsdir);
6215 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
6221 /* Make sure we are using the right buffer */
6222 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6225 my_esa_len = rms_nam_esll(dirnam);
6229 my_esa_len = rms_nam_esl(dirnam);
6230 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6233 my_esa[my_esa_len] = '\0';
6234 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6235 cp1 = strchr(my_esa,']');
6236 if (!cp1) cp1 = strchr(my_esa,'>');
6237 if (cp1) { /* Should always be true */
6238 my_esa_len -= cp1 - my_esa - 1;
6239 memmove(my_esa, cp1 + 1, my_esa_len);
6242 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6243 /* Yep; check version while we're at it, if it's there. */
6244 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6245 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6246 /* Something other than .DIR[;1]. Bzzt. */
6247 sts = rms_free_search_context(&dirfab);
6251 PerlMem_free(trndir);
6252 PerlMem_free(vmsdir);
6254 set_vaxc_errno(RMS$_DIR);
6259 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6260 /* They provided at least the name; we added the type, if necessary, */
6261 my_strlcpy(buf, my_esa, VMS_MAXRSS);
6262 sts = rms_free_search_context(&dirfab);
6263 PerlMem_free(trndir);
6267 PerlMem_free(vmsdir);
6270 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6271 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6275 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6276 if (cp1 == NULL) { /* should never happen */
6277 sts = rms_free_search_context(&dirfab);
6278 PerlMem_free(trndir);
6282 PerlMem_free(vmsdir);
6287 retlen = strlen(my_esa);
6288 cp1 = strrchr(my_esa,'.');
6289 /* ODS-5 directory specifications can have extra "." in them. */
6290 /* Fix-me, can not scan EFS file specifications backwards */
6291 while (cp1 != NULL) {
6292 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6296 while ((cp1 > my_esa) && (*cp1 != '.'))
6303 if ((cp1) != NULL) {
6304 /* There's more than one directory in the path. Just roll back. */
6306 my_strlcpy(buf, my_esa, VMS_MAXRSS);
6309 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6310 /* Go back and expand rooted logical name */
6311 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6312 #ifdef NAM$M_NO_SHORT_UPCASE
6313 if (decc_efs_case_preserve)
6314 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6316 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6317 sts = rms_free_search_context(&dirfab);
6321 PerlMem_free(trndir);
6322 PerlMem_free(vmsdir);
6324 set_vaxc_errno(dirfab.fab$l_sts);
6328 /* This changes the length of the string of course */
6330 my_esa_len = rms_nam_esll(dirnam);
6332 my_esa_len = rms_nam_esl(dirnam);
6335 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6336 cp1 = strstr(my_esa,"][");
6337 if (!cp1) cp1 = strstr(my_esa,"]<");
6338 dirlen = cp1 - my_esa;
6339 memcpy(buf, my_esa, dirlen);
6340 if (!strncmp(cp1+2,"000000]",7)) {
6341 buf[dirlen-1] = '\0';
6342 /* fix-me Not full ODS-5, just extra dots in directories for now */
6343 cp1 = buf + dirlen - 1;
6349 if (*(cp1-1) != '^')
6354 if (*cp1 == '.') *cp1 = ']';
6356 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6357 memmove(cp1+1,"000000]",7);
6361 memmove(buf+dirlen, cp1+2, retlen-dirlen);
6363 /* Convert last '.' to ']' */
6365 while (*cp != '[') {
6368 /* Do not trip on extra dots in ODS-5 directories */
6369 if ((cp1 == buf) || (*(cp1-1) != '^'))
6373 if (*cp1 == '.') *cp1 = ']';
6375 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6376 memmove(cp1+1,"000000]",7);
6380 else { /* This is a top-level dir. Add the MFD to the path. */
6383 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6384 strcpy(cp2,":[000000]");
6389 sts = rms_free_search_context(&dirfab);
6390 /* We've set up the string up through the filename. Add the
6391 type and version, and we're done. */
6392 strcat(buf,".DIR;1");
6394 /* $PARSE may have upcased filespec, so convert output to lower
6395 * case if input contained any lowercase characters. */
6396 if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6397 PerlMem_free(trndir);
6401 PerlMem_free(vmsdir);
6404 } /* end of int_fileify_dirspec() */
6407 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6408 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6410 static char __fileify_retbuf[VMS_MAXRSS];
6411 char * fileified, *ret_spec, *ret_buf;
6415 if (ret_buf == NULL) {
6417 Newx(fileified, VMS_MAXRSS, char);
6418 if (fileified == NULL)
6419 _ckvmssts(SS$_INSFMEM);
6420 ret_buf = fileified;
6422 ret_buf = __fileify_retbuf;
6426 ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6428 if (ret_spec == NULL) {
6429 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6431 Safefree(fileified);
6435 } /* end of do_fileify_dirspec() */
6438 /* External entry points */
6439 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6440 { return do_fileify_dirspec(dir,buf,0,NULL); }
6441 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6442 { return do_fileify_dirspec(dir,buf,1,NULL); }
6443 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6444 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6445 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6446 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6448 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6449 char * v_spec, int v_len, char * r_spec, int r_len,
6450 char * d_spec, int d_len, char * n_spec, int n_len,
6451 char * e_spec, int e_len, char * vs_spec, int vs_len) {
6453 /* VMS specification - Try to do this the simple way */
6454 if ((v_len + r_len > 0) || (d_len > 0)) {
6457 /* No name or extension component, already a directory */
6458 if ((n_len + e_len + vs_len) == 0) {
6463 /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6464 /* This results from catfile() being used instead of catdir() */
6465 /* So even though it should not work, we need to allow it */
6467 /* If this is .DIR;1 then do a simple conversion */
6468 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6469 if (is_dir || (e_len == 0) && (d_len > 0)) {
6471 len = v_len + r_len + d_len - 1;
6472 char dclose = d_spec[d_len - 1];
6473 memcpy(buf, dir, len);
6476 memcpy(&buf[len], n_spec, n_len);
6479 buf[len + 1] = '\0';
6484 else if (d_len > 0) {
6485 /* In the olden days, a directory needed to have a .DIR */
6486 /* extension to be a valid directory, but now it could */
6487 /* be a symbolic link */
6489 len = v_len + r_len + d_len - 1;
6490 char dclose = d_spec[d_len - 1];
6491 memcpy(buf, dir, len);
6494 memcpy(&buf[len], n_spec, n_len);
6497 if (decc_efs_charset) {
6500 memcpy(&buf[len], e_spec, e_len);
6503 set_vaxc_errno(RMS$_DIR);
6509 buf[len + 1] = '\0';
6514 set_vaxc_errno(RMS$_DIR);
6520 set_vaxc_errno(RMS$_DIR);
6526 /* Internal routine to make sure or convert a directory to be in a */
6527 /* path specification. No utf8 flag because it is not changed or used */
6528 static char *int_pathify_dirspec(const char *dir, char *buf)
6530 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6531 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6532 char * exp_spec, *ret_spec;
6534 unsigned short int trnlnm_iter_count;
6538 if (vms_debug_fileify) {
6540 fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6542 fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6545 /* We may need to lower case the result if we translated */
6546 /* a logical name or got the current working directory */
6549 if (!dir || !*dir) {
6551 set_vaxc_errno(SS$_BADPARAM);
6555 trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
6557 _ckvmssts_noperl(SS$_INSFMEM);
6559 /* If no directory specified use the current default */
6561 my_strlcpy(trndir, dir, VMS_MAXRSS);
6563 getcwd(trndir, VMS_MAXRSS - 1);
6567 /* now deal with bare names that could be logical names */
6568 trnlnm_iter_count = 0;
6569 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6570 && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6571 trnlnm_iter_count++;
6573 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6575 trnlen = strlen(trndir);
6577 /* Trap simple rooted lnms, and return lnm:[000000] */
6578 if (!strcmp(trndir+trnlen-2,".]")) {
6579 my_strlcpy(buf, dir, VMS_MAXRSS);
6580 strcat(buf, ":[000000]");
6581 PerlMem_free(trndir);
6583 if (vms_debug_fileify) {
6584 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6590 /* At this point we do not work with *dir, but the copy in *trndir */
6592 if (need_to_lower && !decc_efs_case_preserve) {
6593 /* Legacy mode, lower case the returned value */
6594 __mystrtolower(trndir);
6598 /* Some special cases, '..', '.' */
6600 if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6601 /* Force UNIX filespec */
6605 /* Is this Unix or VMS format? */
6606 sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6607 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6608 &e_len, &vs_spec, &vs_len);
6611 /* Just a filename? */
6612 if ((v_len + r_len + d_len) == 0) {
6614 /* Now we have a problem, this could be Unix or VMS */
6615 /* We have to guess. .DIR usually means VMS */
6617 /* In UNIX report mode, the .DIR extension is removed */
6618 /* if one shows up, it is for a non-directory or a directory */
6619 /* in EFS charset mode */
6621 /* So if we are in Unix report mode, assume that this */
6622 /* is a relative Unix directory specification */
6625 if (!decc_filename_unix_report && decc_efs_charset) {
6627 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6630 /* Traditional mode, assume .DIR is directory */
6633 memcpy(&buf[2], n_spec, n_len);
6634 buf[n_len + 2] = ']';
6635 buf[n_len + 3] = '\0';
6636 PerlMem_free(trndir);
6637 if (vms_debug_fileify) {
6639 "int_pathify_dirspec: buf = %s\n",
6649 ret_spec = int_pathify_dirspec_simple(trndir, buf,
6650 v_spec, v_len, r_spec, r_len,
6651 d_spec, d_len, n_spec, n_len,
6652 e_spec, e_len, vs_spec, vs_len);
6654 if (ret_spec != NULL) {
6655 PerlMem_free(trndir);
6656 if (vms_debug_fileify) {
6658 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6663 /* Simple way did not work, which means that a logical name */
6664 /* was present for the directory specification. */
6665 /* Need to use an rmsexpand variant to decode it completely */
6666 exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
6667 if (exp_spec == NULL)
6668 _ckvmssts_noperl(SS$_INSFMEM);
6670 ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6671 if (ret_spec != NULL) {
6672 sts = vms_split_path(exp_spec, &v_spec, &v_len,
6673 &r_spec, &r_len, &d_spec, &d_len,
6674 &n_spec, &n_len, &e_spec,
6675 &e_len, &vs_spec, &vs_len);
6677 ret_spec = int_pathify_dirspec_simple(
6678 exp_spec, buf, v_spec, v_len, r_spec, r_len,
6679 d_spec, d_len, n_spec, n_len,
6680 e_spec, e_len, vs_spec, vs_len);
6682 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6683 /* Legacy mode, lower case the returned value */
6684 __mystrtolower(ret_spec);
6687 set_vaxc_errno(RMS$_DIR);
6692 PerlMem_free(exp_spec);
6693 PerlMem_free(trndir);
6694 if (vms_debug_fileify) {
6695 if (ret_spec == NULL)
6696 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6699 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6704 /* Unix specification, Could be trivial conversion, */
6705 /* but have to deal with trailing '.dir' or extra '.' */
6710 STRLEN dir_len = strlen(trndir);
6712 lastslash = strrchr(trndir, '/');
6713 if (lastslash == NULL)
6720 /* '..' or '.' are valid directory components */
6722 if (lastslash[0] == '.') {
6723 if (lastslash[1] == '\0') {
6725 } else if (lastslash[1] == '.') {
6726 if (lastslash[2] == '\0') {
6729 /* And finally allow '...' */
6730 if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6738 lastdot = strrchr(lastslash, '.');
6740 if (lastdot != NULL) {
6742 /* '.dir' is discarded, and any other '.' is invalid */
6743 e_len = strlen(lastdot);
6745 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6748 dir_len = dir_len - 4;
6752 my_strlcpy(buf, trndir, VMS_MAXRSS);
6753 if (buf[dir_len - 1] != '/') {
6755 buf[dir_len + 1] = '\0';
6758 /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6759 if (!decc_efs_charset) {
6762 if (str[0] == '.') {
6765 while ((dots[cnt] == '.') && (cnt < 3))
6768 if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6774 for (; *str; ++str) {
6775 while (*str == '/') {
6781 /* Have to skip up to three dots which could be */
6782 /* directories, 3 dots being a VMS extension for Perl */
6785 while ((dots[cnt] == '.') && (cnt < 3)) {
6788 if (dots[cnt] == '\0')
6790 if ((cnt > 1) && (dots[cnt] != '/')) {
6796 /* too many dots? */
6797 if ((cnt == 0) || (cnt > 3)) {
6801 if (!dir_start && (*str == '.')) {
6806 PerlMem_free(trndir);
6808 if (vms_debug_fileify) {
6809 if (ret_spec == NULL)
6810 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6813 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6819 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6820 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6822 static char __pathify_retbuf[VMS_MAXRSS];
6823 char * pathified, *ret_spec, *ret_buf;
6827 if (ret_buf == NULL) {
6829 Newx(pathified, VMS_MAXRSS, char);
6830 if (pathified == NULL)
6831 _ckvmssts(SS$_INSFMEM);
6832 ret_buf = pathified;
6834 ret_buf = __pathify_retbuf;
6838 ret_spec = int_pathify_dirspec(dir, ret_buf);
6840 if (ret_spec == NULL) {
6841 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6843 Safefree(pathified);
6848 } /* end of do_pathify_dirspec() */
6851 /* External entry points */
6852 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6853 { return do_pathify_dirspec(dir,buf,0,NULL); }
6854 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6855 { return do_pathify_dirspec(dir,buf,1,NULL); }
6856 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6857 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6858 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6859 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6861 /* Internal tounixspec routine that does not use a thread context */
6862 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6863 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6865 char *dirend, *cp1, *cp3, *tmp;
6868 unsigned short int trnlnm_iter_count;
6870 if (utf8_fl != NULL)
6873 if (vms_debug_fileify) {
6875 fprintf(stderr, "int_tounixspec: spec = NULL\n");
6877 fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6883 set_vaxc_errno(SS$_BADPARAM);
6886 if (strlen(spec) > (VMS_MAXRSS-1)) {
6888 set_vaxc_errno(SS$_BUFFEROVF);
6892 /* New VMS specific format needs translation
6893 * glob passes filenames with trailing '\n' and expects this preserved.
6895 if (decc_posix_compliant_pathnames) {
6896 if (strncmp(spec, "\"^UP^", 5) == 0) {
6902 tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
6903 if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6904 tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
6906 if (tunix[tunix_len - 1] == '\n') {
6907 tunix[tunix_len - 1] = '\"';
6908 tunix[tunix_len] = '\0';
6912 uspec = decc$translate_vms(tunix);
6913 PerlMem_free(tunix);
6914 if ((int)uspec > 0) {
6915 my_strlcpy(rslt, uspec, VMS_MAXRSS);
6920 /* If we can not translate it, makemaker wants as-is */
6921 my_strlcpy(rslt, spec, VMS_MAXRSS);
6928 cmp_rslt = 0; /* Presume VMS */
6929 cp1 = strchr(spec, '/');
6933 /* Look for EFS ^/ */
6934 if (decc_efs_charset) {
6935 while (cp1 != NULL) {
6938 /* Found illegal VMS, assume UNIX */
6943 cp1 = strchr(cp1, '/');
6947 /* Look for "." and ".." */
6948 if (decc_filename_unix_report) {
6949 if (spec[0] == '.') {
6950 if ((spec[1] == '\0') || (spec[1] == '\n')) {
6954 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6960 /* This is already UNIX or at least nothing VMS understands */
6962 my_strlcpy(rslt, spec, VMS_MAXRSS);
6963 if (vms_debug_fileify) {
6964 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6971 dirend = strrchr(spec,']');
6972 if (dirend == NULL) dirend = strrchr(spec,'>');
6973 if (dirend == NULL) dirend = strchr(spec,':');
6974 if (dirend == NULL) {
6976 if (vms_debug_fileify) {
6977 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6982 /* Special case 1 - sys$posix_root = / */
6983 if (!decc_disable_posix_root) {
6984 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6991 /* Special case 2 - Convert NLA0: to /dev/null */
6992 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6993 if (cmp_rslt == 0) {
6994 strcpy(rslt, "/dev/null");
6997 if (spec[6] != '\0') {
7004 /* Also handle special case "SYS$SCRATCH:" */
7005 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7006 tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
7007 if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7008 if (cmp_rslt == 0) {
7011 islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7013 strcpy(rslt, "/tmp");
7016 if (spec[12] != '\0') {
7024 if (*cp2 != '[' && *cp2 != '<') {
7027 else { /* the VMS spec begins with directories */
7029 if (*cp2 == ']' || *cp2 == '>') {
7030 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7034 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7035 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7037 if (vms_debug_fileify) {
7038 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7042 trnlnm_iter_count = 0;
7045 while (*cp3 != ':' && *cp3) cp3++;
7047 if (strchr(cp3,']') != NULL) break;
7048 trnlnm_iter_count++;
7049 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7050 } while (vmstrnenv(tmp,tmp,0,fildev,0));
7055 *(cp1++) = *(cp3++);
7056 if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7058 set_errno(ENAMETOOLONG);
7059 set_vaxc_errno(SS$_BUFFEROVF);
7060 if (vms_debug_fileify) {
7061 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7063 return NULL; /* No room */
7068 if ((*cp2 == '^')) {
7069 /* EFS file escape, pass the next character as is */
7070 /* Fix me: HEX encoding for Unicode not implemented */
7073 else if ( *cp2 == '.') {
7074 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7075 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7082 for (; cp2 <= dirend; cp2++) {
7083 if ((*cp2 == '^')) {
7084 /* EFS file escape, pass the next character as is */
7085 /* Fix me: HEX encoding for Unicode not implemented */
7086 *(cp1++) = *(++cp2);
7087 /* An escaped dot stays as is -- don't convert to slash */
7088 if (*cp2 == '.') cp2++;
7092 if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7094 else if (*cp2 == ']' || *cp2 == '>') {
7095 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7097 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7099 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7100 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7101 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7102 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7103 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7105 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7106 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7110 else if (*cp2 == '-') {
7111 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7112 while (*cp2 == '-') {
7114 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7116 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7117 /* filespecs like */
7118 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
7119 if (vms_debug_fileify) {
7120 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7125 else *(cp1++) = *cp2;
7127 else *(cp1++) = *cp2;
7129 /* Translate the rest of the filename. */
7134 /* Fixme - for compatibility with the CRTL we should be removing */
7135 /* spaces from the file specifications, but this may show that */
7136 /* some tests that were appearing to pass are not really passing */
7142 /* Fix me hex expansions not implemented */
7143 cp2++; /* '^.' --> '.' and other. */
7149 *(cp1++) = *(cp2++);
7154 if (decc_filename_unix_no_version) {
7155 /* Easy, drop the version */
7160 /* Punt - passing the version as a dot will probably */
7161 /* break perl in weird ways, but so did passing */
7162 /* through the ; as a version. Follow the CRTL and */
7163 /* hope for the best. */
7170 /* We will need to fix this properly later */
7171 /* As Perl may be installed on an ODS-5 volume, but not */
7172 /* have the EFS_CHARSET enabled, it still may encounter */
7173 /* filenames with extra dots in them, and a precedent got */
7174 /* set which allowed them to work, that we will uphold here */
7175 /* If extra dots are present in a name and no ^ is on them */
7176 /* VMS assumes that the first one is the extension delimiter */
7177 /* the rest have an implied ^. */
7179 /* this is also a conflict as the . is also a version */
7180 /* delimiter in VMS, */
7182 *(cp1++) = *(cp2++);
7186 /* This is an extension */
7187 if (decc_readdir_dropdotnotype) {
7189 if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7190 /* Drop the dot for the extension */
7198 *(cp1++) = *(cp2++);
7203 /* This still leaves /000000/ when working with a
7204 * VMS device root or concealed root.
7210 ulen = strlen(rslt);
7212 /* Get rid of "000000/ in rooted filespecs */
7214 zeros = strstr(rslt, "/000000/");
7215 if (zeros != NULL) {
7217 mlen = ulen - (zeros - rslt) - 7;
7218 memmove(zeros, &zeros[7], mlen);
7225 if (vms_debug_fileify) {
7226 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7230 } /* end of int_tounixspec() */
7233 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7234 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7236 static char __tounixspec_retbuf[VMS_MAXRSS];
7237 char * unixspec, *ret_spec, *ret_buf;
7241 if (ret_buf == NULL) {
7243 Newx(unixspec, VMS_MAXRSS, char);
7244 if (unixspec == NULL)
7245 _ckvmssts(SS$_INSFMEM);
7248 ret_buf = __tounixspec_retbuf;
7252 ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7254 if (ret_spec == NULL) {
7255 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7262 } /* end of do_tounixspec() */
7264 /* External entry points */
7265 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7266 { return do_tounixspec(spec,buf,0, NULL); }
7267 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7268 { return do_tounixspec(spec,buf,1, NULL); }
7269 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7270 { return do_tounixspec(spec,buf,0, utf8_fl); }
7271 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7272 { return do_tounixspec(spec,buf,1, utf8_fl); }
7274 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7277 This procedure is used to identify if a path is based in either
7278 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7279 it returns the OpenVMS format directory for it.
7281 It is expecting specifications of only '/' or '/xxxx/'
7283 If a posix root does not exist, or 'xxxx' is not a directory
7284 in the posix root, it returns a failure.
7286 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7288 It is used only internally by posix_to_vmsspec_hardway().
7291 static int posix_root_to_vms
7292 (char *vmspath, int vmspath_len,
7293 const char *unixpath,
7294 const int * utf8_fl)
7297 struct FAB myfab = cc$rms_fab;
7298 rms_setup_nam(mynam);
7299 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7300 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7301 char * esa, * esal, * rsa, * rsal;
7307 unixlen = strlen(unixpath);
7312 #if __CRTL_VER >= 80200000
7313 /* If not a posix spec already, convert it */
7314 if (decc_posix_compliant_pathnames) {
7315 if (strncmp(unixpath,"\"^UP^",5) != 0) {
7316 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7319 /* This is already a VMS specification, no conversion */
7321 my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7330 /* Check to see if this is under the POSIX root */
7331 if (decc_disable_posix_root) {
7335 /* Skip leading / */
7336 if (unixpath[0] == '/') {
7342 strcpy(vmspath,"SYS$POSIX_ROOT:");
7344 /* If this is only the / , or blank, then... */
7345 if (unixpath[0] == '\0') {
7346 /* by definition, this is the answer */
7350 /* Need to look up a directory */
7354 /* Copy and add '^' escape characters as needed */
7357 while (unixpath[i] != 0) {
7360 j += copy_expand_unix_filename_escape
7361 (&vmspath[j], &unixpath[i], &k, utf8_fl);
7365 path_len = strlen(vmspath);
7366 if (vmspath[path_len - 1] == '/')
7368 vmspath[path_len] = ']';
7370 vmspath[path_len] = '\0';
7373 vmspath[vmspath_len] = 0;
7374 if (unixpath[unixlen - 1] == '/')
7376 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7377 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7378 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7379 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7380 rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7381 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7382 rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7383 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7384 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7385 rms_bind_fab_nam(myfab, mynam);
7386 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7387 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7388 if (decc_efs_case_preserve)
7389 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7390 #ifdef NAML$M_OPEN_SPECIAL
7391 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7394 /* Set up the remaining naml fields */
7395 sts = sys$parse(&myfab);
7397 /* It failed! Try again as a UNIX filespec */
7406 /* get the Device ID and the FID */
7407 sts = sys$search(&myfab);
7409 /* These are no longer needed */
7414 /* on any failure, returned the POSIX ^UP^ filespec */
7419 specdsc.dsc$a_pointer = vmspath;
7420 specdsc.dsc$w_length = vmspath_len;
7422 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7423 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7424 sts = lib$fid_to_name
7425 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7427 /* on any failure, returned the POSIX ^UP^ filespec */
7429 /* This can happen if user does not have permission to read directories */
7430 if (strncmp(unixpath,"\"^UP^",5) != 0)
7431 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7433 my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7436 vmspath[specdsc.dsc$w_length] = 0;
7438 /* Are we expecting a directory? */
7439 if (dir_flag != 0) {
7445 i = specdsc.dsc$w_length - 1;
7449 /* Version must be '1' */
7450 if (vmspath[i--] != '1')
7452 /* Version delimiter is one of ".;" */
7453 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7456 if (vmspath[i--] != 'R')
7458 if (vmspath[i--] != 'I')
7460 if (vmspath[i--] != 'D')
7462 if (vmspath[i--] != '.')
7464 eptr = &vmspath[i+1];
7466 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7467 if (vmspath[i-1] != '^') {
7475 /* Get rid of 6 imaginary zero directory filename */
7476 vmspath[i+1] = '\0';
7480 if (vmspath[i] == '0')
7494 /* /dev/mumble needs to be handled special.
7495 /dev/null becomes NLA0:, And there is the potential for other stuff
7496 like /dev/tty which may need to be mapped to something.
7500 slash_dev_special_to_vms
7501 (const char * unixptr,
7510 nextslash = strchr(unixptr, '/');
7511 len = strlen(unixptr);
7512 if (nextslash != NULL)
7513 len = nextslash - unixptr;
7514 cmp = strncmp("null", unixptr, 5);
7516 if (vmspath_len >= 6) {
7517 strcpy(vmspath, "_NLA0:");
7525 /* The built in routines do not understand perl's special needs, so
7526 doing a manual conversion from UNIX to VMS
7528 If the utf8_fl is not null and points to a non-zero value, then
7529 treat 8 bit characters as UTF-8.
7531 The sequence starting with '$(' and ending with ')' will be passed
7532 through with out interpretation instead of being escaped.
7535 static int posix_to_vmsspec_hardway
7536 (char *vmspath, int vmspath_len,
7537 const char *unixpath,
7542 const char *unixptr;
7543 const char *unixend;
7545 const char *lastslash;
7546 const char *lastdot;
7552 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7553 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7555 if (utf8_fl != NULL)
7561 /* Ignore leading "/" characters */
7562 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7565 unixlen = strlen(unixptr);
7567 /* Do nothing with blank paths */
7574 /* This could have a "^UP^ on the front */
7575 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7581 lastslash = strrchr(unixptr,'/');
7582 lastdot = strrchr(unixptr,'.');
7583 unixend = strrchr(unixptr,'\"');
7584 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7585 unixend = unixptr + unixlen;
7588 /* last dot is last dot or past end of string */
7589 if (lastdot == NULL)
7590 lastdot = unixptr + unixlen;
7592 /* if no directories, set last slash to beginning of string */
7593 if (lastslash == NULL) {
7594 lastslash = unixptr;
7597 /* Watch out for trailing "." after last slash, still a directory */
7598 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7599 lastslash = unixptr + unixlen;
7602 /* Watch out for trailing ".." after last slash, still a directory */
7603 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7604 lastslash = unixptr + unixlen;
7607 /* dots in directories are aways escaped */
7608 if (lastdot < lastslash)
7609 lastdot = unixptr + unixlen;
7612 /* if (unixptr < lastslash) then we are in a directory */
7619 /* Start with the UNIX path */
7620 if (*unixptr != '/') {
7621 /* relative paths */
7623 /* If allowing logical names on relative pathnames, then handle here */
7624 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7625 !decc_posix_compliant_pathnames) {
7631 /* Find the next slash */
7632 nextslash = strchr(unixptr,'/');
7634 esa = (char *)PerlMem_malloc(vmspath_len);
7635 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7637 trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7638 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7640 if (nextslash != NULL) {
7642 seg_len = nextslash - unixptr;
7643 memcpy(esa, unixptr, seg_len);
7647 seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7649 /* trnlnm(section) */
7650 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7653 /* Now fix up the directory */
7655 /* Split up the path to find the components */
7656 sts = vms_split_path
7674 /* A logical name must be a directory or the full
7675 specification. It is only a full specification if
7676 it is the only component */
7677 if ((unixptr[seg_len] == '\0') ||
7678 (unixptr[seg_len+1] == '\0')) {
7680 /* Is a directory being required? */
7681 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7682 /* Not a logical name */
7687 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7688 /* This must be a directory */
7689 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7690 vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7691 vmsptr[vmslen] = ':';
7693 vmsptr[vmslen] = '\0';
7701 /* must be dev/directory - ignore version */
7702 if ((n_len + e_len) != 0)
7705 /* transfer the volume */
7706 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7707 memcpy(vmsptr, v_spec, v_len);
7713 /* unroot the rooted directory */
7714 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7716 r_spec[r_len - 1] = ']';
7718 /* This should not be there, but nothing is perfect */
7720 cmp = strcmp(&r_spec[1], "000000.");
7730 memcpy(vmsptr, r_spec, r_len);
7736 /* Bring over the directory. */
7738 ((d_len + vmslen) < vmspath_len)) {
7740 d_spec[d_len - 1] = ']';
7742 cmp = strcmp(&d_spec[1], "000000.");
7753 /* Remove the redundant root */
7761 memcpy(vmsptr, d_spec, d_len);
7775 if (lastslash > unixptr) {
7778 /* skip leading ./ */
7780 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7786 /* Are we still in a directory? */
7787 if (unixptr <= lastslash) {
7792 /* if not backing up, then it is relative forward. */
7793 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7794 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7802 /* Perl wants an empty directory here to tell the difference
7803 * between a DCL command and a filename
7812 /* Handle two special files . and .. */
7813 if (unixptr[0] == '.') {
7814 if (&unixptr[1] == unixend) {
7821 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7832 else { /* Absolute PATH handling */
7836 /* Need to find out where root is */
7838 /* In theory, this procedure should never get an absolute POSIX pathname
7839 * that can not be found on the POSIX root.
7840 * In practice, that can not be relied on, and things will show up
7841 * here that are a VMS device name or concealed logical name instead.
7842 * So to make things work, this procedure must be tolerant.
7844 esa = (char *)PerlMem_malloc(vmspath_len);
7845 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7848 nextslash = strchr(&unixptr[1],'/');
7850 if (nextslash != NULL) {
7852 seg_len = nextslash - &unixptr[1];
7853 my_strlcpy(vmspath, unixptr, seg_len + 2);
7856 cmp = strncmp(vmspath, "dev", 4);
7858 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7859 if (sts == SS$_NORMAL)
7863 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7866 if ($VMS_STATUS_SUCCESS(sts)) {
7867 /* This is verified to be a real path */
7869 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7870 if ($VMS_STATUS_SUCCESS(sts)) {
7871 vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
7872 vmsptr = vmspath + vmslen;
7874 if (unixptr < lastslash) {
7883 cmp = strcmp(rptr,"000000.");
7888 } /* removing 6 zeros */
7889 } /* vmslen < 7, no 6 zeros possible */
7890 } /* Not in a directory */
7891 } /* Posix root found */
7893 /* No posix root, fall back to default directory */
7894 strcpy(vmspath, "SYS$DISK:[");
7895 vmsptr = &vmspath[10];
7897 if (unixptr > lastslash) {
7906 } /* end of verified real path handling */
7911 /* Ok, we have a device or a concealed root that is not in POSIX
7912 * or we have garbage. Make the best of it.
7915 /* Posix to VMS destroyed this, so copy it again */
7916 my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
7917 vmslen = strlen(vmspath); /* We know we're truncating. */
7918 vmsptr = &vmsptr[vmslen];
7921 /* Now do we need to add the fake 6 zero directory to it? */
7923 if ((*lastslash == '/') && (nextslash < lastslash)) {
7924 /* No there is another directory */
7931 /* now we have foo:bar or foo:[000000]bar to decide from */
7932 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7934 if (!islnm && !decc_posix_compliant_pathnames) {
7936 cmp = strncmp("bin", vmspath, 4);
7938 /* bin => SYS$SYSTEM: */
7939 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7942 /* tmp => SYS$SCRATCH: */
7943 cmp = strncmp("tmp", vmspath, 4);
7945 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7950 trnend = islnm ? islnm - 1 : 0;
7952 /* if this was a logical name, ']' or '>' must be present */
7953 /* if not a logical name, then assume a device and hope. */
7954 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7956 /* if log name and trailing '.' then rooted - treat as device */
7957 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7959 /* Fix me, if not a logical name, a device lookup should be
7960 * done to see if the device is file structured. If the device
7961 * is not file structured, the 6 zeros should not be put on.
7963 * As it is, perl is occasionally looking for dev:[000000]tty.
7964 * which looks a little strange.
7966 * Not that easy to detect as "/dev" may be file structured with
7967 * special device files.
7970 if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
7971 (&nextslash[1] == unixend)) {
7972 /* No real directory present */
7977 /* Put the device delimiter on */
7980 unixptr = nextslash;
7983 /* Start directory if needed */
7984 if (!islnm || add_6zero) {
7990 /* add fake 000000] if needed */
8003 } /* non-POSIX translation */
8005 } /* End of relative/absolute path handling */
8007 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8014 if (dir_start != 0) {
8016 /* First characters in a directory are handled special */
8017 while ((*unixptr == '/') ||
8018 ((*unixptr == '.') &&
8019 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8020 (&unixptr[1]==unixend)))) {
8025 /* Skip redundant / in specification */
8026 while ((*unixptr == '/') && (dir_start != 0)) {
8029 if (unixptr == lastslash)
8032 if (unixptr == lastslash)
8035 /* Skip redundant ./ characters */
8036 while ((*unixptr == '.') &&
8037 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8040 if (unixptr == lastslash)
8042 if (*unixptr == '/')
8045 if (unixptr == lastslash)
8048 /* Skip redundant ../ characters */
8049 while ((*unixptr == '.') && (unixptr[1] == '.') &&
8050 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8051 /* Set the backing up flag */
8057 unixptr++; /* first . */
8058 unixptr++; /* second . */
8059 if (unixptr == lastslash)
8061 if (*unixptr == '/') /* The slash */
8064 if (unixptr == lastslash)
8067 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8068 /* Not needed when VMS is pretending to be UNIX. */
8070 /* Is this loop stuck because of too many dots? */
8071 if (loop_flag == 0) {
8072 /* Exit the loop and pass the rest through */
8077 /* Are we done with directories yet? */
8078 if (unixptr >= lastslash) {
8080 /* Watch out for trailing dots */
8089 if (*unixptr == '/')
8093 /* Have we stopped backing up? */
8098 /* dir_start continues to be = 1 */
8100 if (*unixptr == '-') {
8102 *vmsptr++ = *unixptr++;
8106 /* Now are we done with directories yet? */
8107 if (unixptr >= lastslash) {
8109 /* Watch out for trailing dots */
8125 if (unixptr >= unixend)
8128 /* Normal characters - More EFS work probably needed */
8134 /* remove multiple / */
8135 while (unixptr[1] == '/') {
8138 if (unixptr == lastslash) {
8139 /* Watch out for trailing dots */
8151 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8152 /* Not needed when VMS is pretending to be UNIX. */
8156 if (unixptr != unixend)
8161 if ((unixptr < lastdot) || (unixptr < lastslash) ||
8162 (&unixptr[1] == unixend)) {
8168 /* trailing dot ==> '^..' on VMS */
8169 if (unixptr == unixend) {
8177 *vmsptr++ = *unixptr++;
8181 if (quoted && (&unixptr[1] == unixend)) {
8185 in_cnt = copy_expand_unix_filename_escape
8186 (vmsptr, unixptr, &out_cnt, utf8_fl);
8196 in_cnt = copy_expand_unix_filename_escape
8197 (vmsptr, unixptr, &out_cnt, utf8_fl);
8204 /* Make sure directory is closed */
8205 if (unixptr == lastslash) {
8207 vmsptr2 = vmsptr - 1;
8209 if (*vmsptr2 != ']') {
8212 /* directories do not end in a dot bracket */
8213 if (*vmsptr2 == '.') {
8217 if (*vmsptr2 != '^') {
8218 vmsptr--; /* back up over the dot */
8226 /* Add a trailing dot if a file with no extension */
8227 vmsptr2 = vmsptr - 1;
8229 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8230 (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8241 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8242 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8247 /* If a UTF8 flag is being passed, honor it */
8249 if (utf8_fl != NULL) {
8250 utf8_flag = *utf8_fl;
8255 /* If there is a possibility of UTF8, then if any UTF8 characters
8256 are present, then they must be converted to VTF-7
8258 result = strcpy(rslt, path); /* FIX-ME */
8261 result = strcpy(rslt, path);
8268 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8269 static char *int_tovmsspec
8270 (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8275 unsigned long int infront = 0, hasdir = 1;
8278 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8279 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8281 if (vms_debug_fileify) {
8283 fprintf(stderr, "int_tovmsspec: path = NULL\n");
8285 fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8289 /* If we fail, we should be setting errno */
8291 set_vaxc_errno(SS$_BADPARAM);
8294 rslt_len = VMS_MAXRSS-1;
8296 /* '.' and '..' are "[]" and "[-]" for a quick check */
8297 if (path[0] == '.') {
8298 if (path[1] == '\0') {
8300 if (utf8_flag != NULL)
8305 if (path[1] == '.' && path[2] == '\0') {
8307 if (utf8_flag != NULL)
8314 /* Posix specifications are now a native VMS format */
8315 /*--------------------------------------------------*/
8316 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8317 if (decc_posix_compliant_pathnames) {
8318 if (strncmp(path,"\"^UP^",5) == 0) {
8319 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8325 /* This is really the only way to see if this is already in VMS format */
8326 sts = vms_split_path
8341 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8342 replacement, because the above parse just took care of most of
8343 what is needed to do vmspath when the specification is already
8346 And if it is not already, it is easier to do the conversion as
8347 part of this routine than to call this routine and then work on
8351 /* If VMS punctuation was found, it is already VMS format */
8352 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8353 if (utf8_flag != NULL)
8355 my_strlcpy(rslt, path, VMS_MAXRSS);
8356 if (vms_debug_fileify) {
8357 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8361 /* Now, what to do with trailing "." cases where there is no
8362 extension? If this is a UNIX specification, and EFS characters
8363 are enabled, then the trailing "." should be converted to a "^.".
8364 But if this was already a VMS specification, then it should be
8367 So in the case of ambiguity, leave the specification alone.
8371 /* If there is a possibility of UTF8, then if any UTF8 characters
8372 are present, then they must be converted to VTF-7
8374 if (utf8_flag != NULL)
8376 my_strlcpy(rslt, path, VMS_MAXRSS);
8377 if (vms_debug_fileify) {
8378 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8383 dirend = strrchr(path,'/');
8385 if (dirend == NULL) {
8389 /* If we get here with no UNIX directory delimiters, then this is
8390 not a complete file specification, either garbage a UNIX glob
8391 specification that can not be converted to a VMS wildcard, or
8392 it a UNIX shell macro. MakeMaker wants shell macros passed
8395 utf8 flag setting needs to be preserved.
8400 macro_start = strchr(path,'$');
8401 if (macro_start != NULL) {
8402 if (macro_start[1] == '(') {
8406 if ((decc_efs_charset == 0) || (has_macro)) {
8407 my_strlcpy(rslt, path, VMS_MAXRSS);
8408 if (vms_debug_fileify) {
8409 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8414 else if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
8415 if (!*(dirend+2)) dirend +=2;
8416 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8417 if (decc_efs_charset == 0) {
8418 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8424 lastdot = strrchr(cp2,'.');
8430 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8432 if (decc_disable_posix_root) {
8433 strcpy(rslt,"sys$disk:[000000]");
8436 strcpy(rslt,"sys$posix_root:[000000]");
8438 if (utf8_flag != NULL)
8440 if (vms_debug_fileify) {
8441 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8445 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8447 trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8448 if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8449 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8451 /* DECC special handling */
8453 if (strcmp(rslt,"bin") == 0) {
8454 strcpy(rslt,"sys$system");
8457 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8459 else if (strcmp(rslt,"tmp") == 0) {
8460 strcpy(rslt,"sys$scratch");
8463 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8465 else if (!decc_disable_posix_root) {
8466 strcpy(rslt, "sys$posix_root");
8470 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8471 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8473 else if (strcmp(rslt,"dev") == 0) {
8474 if (strncmp(cp2,"/null", 5) == 0) {
8475 if ((cp2[5] == 0) || (cp2[5] == '/')) {
8476 strcpy(rslt,"NLA0");
8480 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8486 trnend = islnm ? strlen(trndev) - 1 : 0;
8487 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8488 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8489 /* If the first element of the path is a logical name, determine
8490 * whether it has to be translated so we can add more directories. */
8491 if (!islnm || rooted) {
8494 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8498 if (cp2 != dirend) {
8499 my_strlcpy(rslt, trndev, VMS_MAXRSS);
8500 cp1 = rslt + trnend;
8507 if (decc_disable_posix_root) {
8513 PerlMem_free(trndev);
8518 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8519 cp2 += 2; /* skip over "./" - it's redundant */
8520 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8522 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8523 *(cp1++) = '-'; /* "../" --> "-" */
8526 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8527 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8528 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8529 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8532 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8533 /* Escape the extra dots in EFS file specifications */
8536 if (cp2 > dirend) cp2 = dirend;
8538 else *(cp1++) = '.';
8540 for (; cp2 < dirend; cp2++) {
8542 if (*(cp2-1) == '/') continue;
8543 if (*(cp1-1) != '.') *(cp1++) = '.';
8546 else if (!infront && *cp2 == '.') {
8547 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8548 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
8549 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8550 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8551 else if (*(cp1-2) == '[') *(cp1-1) = '-';
8556 if (cp2 == dirend) break;
8558 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8559 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8560 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8561 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8563 *(cp1++) = '.'; /* Simulate trailing '/' */
8564 cp2 += 2; /* for loop will incr this to == dirend */
8566 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8569 if (decc_efs_charset == 0)
8570 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8572 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8578 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
8580 if (decc_efs_charset == 0)
8587 else *(cp1++) = *cp2;
8591 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8592 if (hasdir) *(cp1++) = ']';
8593 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
8594 /* fixme for ODS5 */
8601 if (decc_efs_charset == 0)
8612 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8613 decc_readdir_dropdotnotype) {
8618 /* trailing dot ==> '^..' on VMS */
8625 *(cp1++) = *(cp2++);
8630 /* This could be a macro to be passed through */
8631 *(cp1++) = *(cp2++);
8633 const char * save_cp2;
8637 /* paranoid check */
8643 *(cp1++) = *(cp2++);
8644 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8645 *(cp1++) = *(cp2++);
8646 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8647 *(cp1++) = *(cp2++);
8650 *(cp1++) = *(cp2++);
8654 if (is_macro == 0) {
8655 /* Not really a macro - never mind */
8668 /* Don't escape again if following character is
8669 * already something we escape.
8671 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8672 *(cp1++) = *(cp2++);
8675 /* But otherwise fall through and escape it. */
8693 *(cp1++) = *(cp2++);
8696 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8697 * which is wrong. UNIX notation should be ".dir." unless
8698 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8699 * changing this behavior could break more things at this time.
8700 * efs character set effectively does not allow "." to be a version
8701 * delimiter as a further complication about changing this.
8703 if (decc_filename_unix_report != 0) {
8706 *(cp1++) = *(cp2++);
8709 *(cp1++) = *(cp2++);
8712 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8716 /* Fix me for "^]", but that requires making sure that you do
8717 * not back up past the start of the filename
8719 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8724 if (utf8_flag != NULL)
8726 if (vms_debug_fileify) {
8727 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8731 } /* end of int_tovmsspec() */
8734 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8735 static char *mp_do_tovmsspec
8736 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8737 static char __tovmsspec_retbuf[VMS_MAXRSS];
8738 char * vmsspec, *ret_spec, *ret_buf;
8742 if (ret_buf == NULL) {
8744 Newx(vmsspec, VMS_MAXRSS, char);
8745 if (vmsspec == NULL)
8746 _ckvmssts(SS$_INSFMEM);
8749 ret_buf = __tovmsspec_retbuf;
8753 ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8755 if (ret_spec == NULL) {
8756 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8763 } /* end of mp_do_tovmsspec() */
8765 /* External entry points */
8766 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8767 { return do_tovmsspec(path,buf,0,NULL); }
8768 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8769 { return do_tovmsspec(path,buf,1,NULL); }
8770 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8771 { return do_tovmsspec(path,buf,0,utf8_fl); }
8772 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8773 { return do_tovmsspec(path,buf,1,utf8_fl); }
8775 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8776 /* Internal routine for use with out an explicit context present */
8777 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
8779 char * ret_spec, *pathified;
8784 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8785 if (pathified == NULL)
8786 _ckvmssts_noperl(SS$_INSFMEM);
8788 ret_spec = int_pathify_dirspec(path, pathified);
8790 if (ret_spec == NULL) {
8791 PerlMem_free(pathified);
8795 ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8797 PerlMem_free(pathified);
8802 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8803 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8804 static char __tovmspath_retbuf[VMS_MAXRSS];
8806 char *pathified, *vmsified, *cp;
8808 if (path == NULL) return NULL;
8809 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8810 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8811 if (int_pathify_dirspec(path, pathified) == NULL) {
8812 PerlMem_free(pathified);
8818 Newx(vmsified, VMS_MAXRSS, char);
8819 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8820 PerlMem_free(pathified);
8821 if (vmsified) Safefree(vmsified);
8824 PerlMem_free(pathified);
8829 vmslen = strlen(vmsified);
8830 Newx(cp,vmslen+1,char);
8831 memcpy(cp,vmsified,vmslen);
8837 my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8839 return __tovmspath_retbuf;
8842 } /* end of do_tovmspath() */
8844 /* External entry points */
8845 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8846 { return do_tovmspath(path,buf,0, NULL); }
8847 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8848 { return do_tovmspath(path,buf,1, NULL); }
8849 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8850 { return do_tovmspath(path,buf,0,utf8_fl); }
8851 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8852 { return do_tovmspath(path,buf,1,utf8_fl); }
8855 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8856 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8857 static char __tounixpath_retbuf[VMS_MAXRSS];
8859 char *pathified, *unixified, *cp;
8861 if (path == NULL) return NULL;
8862 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8863 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8864 if (int_pathify_dirspec(path, pathified) == NULL) {
8865 PerlMem_free(pathified);
8871 Newx(unixified, VMS_MAXRSS, char);
8873 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8874 PerlMem_free(pathified);
8875 if (unixified) Safefree(unixified);
8878 PerlMem_free(pathified);
8883 unixlen = strlen(unixified);
8884 Newx(cp,unixlen+1,char);
8885 memcpy(cp,unixified,unixlen);
8887 Safefree(unixified);
8891 my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
8892 Safefree(unixified);
8893 return __tounixpath_retbuf;
8896 } /* end of do_tounixpath() */
8898 /* External entry points */
8899 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8900 { return do_tounixpath(path,buf,0,NULL); }
8901 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8902 { return do_tounixpath(path,buf,1,NULL); }
8903 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8904 { return do_tounixpath(path,buf,0,utf8_fl); }
8905 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8906 { return do_tounixpath(path,buf,1,utf8_fl); }
8909 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
8911 *****************************************************************************
8913 * Copyright (C) 1989-1994, 2007 by *
8914 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
8916 * Permission is hereby granted for the reproduction of this software *
8917 * on condition that this copyright notice is included in source *
8918 * distributions of the software. The code may be modified and *
8919 * distributed under the same terms as Perl itself. *
8921 * 27-Aug-1994 Modified for inclusion in perl5 *
8922 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
8923 *****************************************************************************
8927 * getredirection() is intended to aid in porting C programs
8928 * to VMS (Vax-11 C). The native VMS environment does not support
8929 * '>' and '<' I/O redirection, or command line wild card expansion,
8930 * or a command line pipe mechanism using the '|' AND background
8931 * command execution '&'. All of these capabilities are provided to any
8932 * C program which calls this procedure as the first thing in the
8934 * The piping mechanism will probably work with almost any 'filter' type
8935 * of program. With suitable modification, it may useful for other
8936 * portability problems as well.
8938 * Author: Mark Pizzolato (mark AT infocomm DOT com)
8942 struct list_item *next;
8946 static void add_item(struct list_item **head,
8947 struct list_item **tail,
8951 static void mp_expand_wild_cards(pTHX_ char *item,
8952 struct list_item **head,
8953 struct list_item **tail,
8956 static int background_process(pTHX_ int argc, char **argv);
8958 static void pipe_and_fork(pTHX_ char **cmargv);
8960 /*{{{ void getredirection(int *ac, char ***av)*/
8962 mp_getredirection(pTHX_ int *ac, char ***av)
8964 * Process vms redirection arg's. Exit if any error is seen.
8965 * If getredirection() processes an argument, it is erased
8966 * from the vector. getredirection() returns a new argc and argv value.
8967 * In the event that a background command is requested (by a trailing "&"),
8968 * this routine creates a background subprocess, and simply exits the program.
8970 * Warning: do not try to simplify the code for vms. The code
8971 * presupposes that getredirection() is called before any data is
8972 * read from stdin or written to stdout.
8974 * Normal usage is as follows:
8980 * getredirection(&argc, &argv);
8984 int argc = *ac; /* Argument Count */
8985 char **argv = *av; /* Argument Vector */
8986 char *ap; /* Argument pointer */
8987 int j; /* argv[] index */
8988 int item_count = 0; /* Count of Items in List */
8989 struct list_item *list_head = 0; /* First Item in List */
8990 struct list_item *list_tail; /* Last Item in List */
8991 char *in = NULL; /* Input File Name */
8992 char *out = NULL; /* Output File Name */
8993 char *outmode = "w"; /* Mode to Open Output File */
8994 char *err = NULL; /* Error File Name */
8995 char *errmode = "w"; /* Mode to Open Error File */
8996 int cmargc = 0; /* Piped Command Arg Count */
8997 char **cmargv = NULL;/* Piped Command Arg Vector */
9000 * First handle the case where the last thing on the line ends with
9001 * a '&'. This indicates the desire for the command to be run in a
9002 * subprocess, so we satisfy that desire.
9005 if (0 == strcmp("&", ap))
9006 exit(background_process(aTHX_ --argc, argv));
9007 if (*ap && '&' == ap[strlen(ap)-1])
9009 ap[strlen(ap)-1] = '\0';
9010 exit(background_process(aTHX_ argc, argv));
9013 * Now we handle the general redirection cases that involve '>', '>>',
9014 * '<', and pipes '|'.
9016 for (j = 0; j < argc; ++j)
9018 if (0 == strcmp("<", argv[j]))
9022 fprintf(stderr,"No input file after < on command line");
9023 exit(LIB$_WRONUMARG);
9028 if ('<' == *(ap = argv[j]))
9033 if (0 == strcmp(">", ap))
9037 fprintf(stderr,"No output file after > on command line");
9038 exit(LIB$_WRONUMARG);
9057 fprintf(stderr,"No output file after > or >> on command line");
9058 exit(LIB$_WRONUMARG);
9062 if (('2' == *ap) && ('>' == ap[1]))
9079 fprintf(stderr,"No output file after 2> or 2>> on command line");
9080 exit(LIB$_WRONUMARG);
9084 if (0 == strcmp("|", argv[j]))
9088 fprintf(stderr,"No command into which to pipe on command line");
9089 exit(LIB$_WRONUMARG);
9091 cmargc = argc-(j+1);
9092 cmargv = &argv[j+1];
9096 if ('|' == *(ap = argv[j]))
9104 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9107 * Allocate and fill in the new argument vector, Some Unix's terminate
9108 * the list with an extra null pointer.
9110 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9111 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9113 for (j = 0; j < item_count; ++j, list_head = list_head->next)
9114 argv[j] = list_head->value;
9120 fprintf(stderr,"'|' and '>' may not both be specified on command line");
9121 exit(LIB$_INVARGORD);
9123 pipe_and_fork(aTHX_ cmargv);
9126 /* Check for input from a pipe (mailbox) */
9128 if (in == NULL && 1 == isapipe(0))
9130 char mbxname[L_tmpnam];
9132 long int dvi_item = DVI$_DEVBUFSIZ;
9133 $DESCRIPTOR(mbxnam, "");
9134 $DESCRIPTOR(mbxdevnam, "");
9136 /* Input from a pipe, reopen it in binary mode to disable */
9137 /* carriage control processing. */
9139 fgetname(stdin, mbxname, 1);
9140 mbxnam.dsc$a_pointer = mbxname;
9141 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9142 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9143 mbxdevnam.dsc$a_pointer = mbxname;
9144 mbxdevnam.dsc$w_length = sizeof(mbxname);
9145 dvi_item = DVI$_DEVNAM;
9146 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9147 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9150 freopen(mbxname, "rb", stdin);
9153 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9157 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9159 fprintf(stderr,"Can't open input file %s as stdin",in);
9162 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9164 fprintf(stderr,"Can't open output file %s as stdout",out);
9167 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9170 if (strcmp(err,"&1") == 0) {
9171 dup2(fileno(stdout), fileno(stderr));
9172 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9175 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9177 fprintf(stderr,"Can't open error file %s as stderr",err);
9181 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9185 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9188 #ifdef ARGPROC_DEBUG
9189 PerlIO_printf(Perl_debug_log, "Arglist:\n");
9190 for (j = 0; j < *ac; ++j)
9191 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9193 /* Clear errors we may have hit expanding wildcards, so they don't
9194 show up in Perl's $! later */
9195 set_errno(0); set_vaxc_errno(1);
9196 } /* end of getredirection() */
9199 static void add_item(struct list_item **head,
9200 struct list_item **tail,
9206 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9207 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9211 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9212 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9213 *tail = (*tail)->next;
9215 (*tail)->value = value;
9219 static void mp_expand_wild_cards(pTHX_ char *item,
9220 struct list_item **head,
9221 struct list_item **tail,
9225 unsigned long int context = 0;
9233 $DESCRIPTOR(filespec, "");
9234 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9235 $DESCRIPTOR(resultspec, "");
9236 unsigned long int lff_flags = 0;
9240 #ifdef VMS_LONGNAME_SUPPORT
9241 lff_flags = LIB$M_FIL_LONG_NAMES;
9244 for (cp = item; *cp; cp++) {
9245 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9246 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9248 if (!*cp || isspace(*cp))
9250 add_item(head, tail, item, count);
9255 /* "double quoted" wild card expressions pass as is */
9256 /* From DCL that means using e.g.: */
9257 /* perl program """perl.*""" */
9258 item_len = strlen(item);
9259 if ( '"' == *item && '"' == item[item_len-1] )
9262 item[item_len-2] = '\0';
9263 add_item(head, tail, item, count);
9267 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9268 resultspec.dsc$b_class = DSC$K_CLASS_D;
9269 resultspec.dsc$a_pointer = NULL;
9270 vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9271 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9272 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9273 filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9274 if (!isunix || !filespec.dsc$a_pointer)
9275 filespec.dsc$a_pointer = item;
9276 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9278 * Only return version specs, if the caller specified a version
9280 had_version = strchr(item, ';');
9282 * Only return device and directory specs, if the caller specified either.
9284 had_device = strchr(item, ':');
9285 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9287 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9288 (&filespec, &resultspec, &context,
9289 &defaultspec, 0, &rms_sts, &lff_flags)))
9294 string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9295 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9296 my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9297 if (NULL == had_version)
9298 *(strrchr(string, ';')) = '\0';
9299 if ((!had_directory) && (had_device == NULL))
9301 if (NULL == (devdir = strrchr(string, ']')))
9302 devdir = strrchr(string, '>');
9303 my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9306 * Be consistent with what the C RTL has already done to the rest of
9307 * the argv items and lowercase all of these names.
9309 if (!decc_efs_case_preserve) {
9310 for (c = string; *c; ++c)
9314 if (isunix) trim_unixpath(string,item,1);
9315 add_item(head, tail, string, count);
9318 PerlMem_free(vmsspec);
9319 if (sts != RMS$_NMF)
9321 set_vaxc_errno(sts);
9324 case RMS$_FNF: case RMS$_DNF:
9325 set_errno(ENOENT); break;
9327 set_errno(ENOTDIR); break;
9329 set_errno(ENODEV); break;
9330 case RMS$_FNM: case RMS$_SYN:
9331 set_errno(EINVAL); break;
9333 set_errno(EACCES); break;
9335 _ckvmssts_noperl(sts);
9339 add_item(head, tail, item, count);
9340 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9341 _ckvmssts_noperl(lib$find_file_end(&context));
9344 static int child_st[2];/* Event Flag set when child process completes */
9346 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
9348 static unsigned long int exit_handler(void)
9352 if (0 == child_st[0])
9354 #ifdef ARGPROC_DEBUG
9355 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9357 fflush(stdout); /* Have to flush pipe for binary data to */
9358 /* terminate properly -- <tp@mccall.com> */
9359 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9360 sys$dassgn(child_chan);
9362 sys$synch(0, child_st);
9367 static void sig_child(int chan)
9369 #ifdef ARGPROC_DEBUG
9370 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9372 if (child_st[0] == 0)
9376 static struct exit_control_block exit_block =
9381 &exit_block.exit_status,
9386 pipe_and_fork(pTHX_ char **cmargv)
9389 struct dsc$descriptor_s *vmscmd;
9390 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9391 int sts, j, l, ismcr, quote, tquote = 0;
9393 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
9394 vms_execfree(vmscmd);
9399 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
9400 && toupper(*(q+2)) == 'R' && !*(q+3);
9402 while (q && l < MAX_DCL_LINE_LENGTH) {
9404 if (j > 0 && quote) {
9410 if (ismcr && j > 1) quote = 1;
9411 tquote = (strchr(q,' ')) != NULL || *q == '\0';
9414 if (quote || tquote) {
9420 if ((quote||tquote) && *q == '"') {
9430 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9432 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9436 static int background_process(pTHX_ int argc, char **argv)
9438 char command[MAX_DCL_SYMBOL + 1] = "$";
9439 $DESCRIPTOR(value, "");
9440 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9441 static $DESCRIPTOR(null, "NLA0:");
9442 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9444 $DESCRIPTOR(pidstr, "");
9446 unsigned long int flags = 17, one = 1, retsts;
9449 len = my_strlcat(command, argv[0], sizeof(command));
9450 while (--argc && (len < MAX_DCL_SYMBOL))
9452 my_strlcat(command, " \"", sizeof(command));
9453 my_strlcat(command, *(++argv), sizeof(command));
9454 len = my_strlcat(command, "\"", sizeof(command));
9456 value.dsc$a_pointer = command;
9457 value.dsc$w_length = strlen(value.dsc$a_pointer);
9458 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9459 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9460 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9461 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9464 _ckvmssts_noperl(retsts);
9466 #ifdef ARGPROC_DEBUG
9467 PerlIO_printf(Perl_debug_log, "%s\n", command);
9469 sprintf(pidstring, "%08X", pid);
9470 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9471 pidstr.dsc$a_pointer = pidstring;
9472 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9473 lib$set_symbol(&pidsymbol, &pidstr);
9477 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9480 /* OS-specific initialization at image activation (not thread startup) */
9481 /* Older VAXC header files lack these constants */
9482 #ifndef JPI$_RIGHTS_SIZE
9483 # define JPI$_RIGHTS_SIZE 817
9485 #ifndef KGB$M_SUBSYSTEM
9486 # define KGB$M_SUBSYSTEM 0x8
9489 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9491 /*{{{void vms_image_init(int *, char ***)*/
9493 vms_image_init(int *argcp, char ***argvp)
9496 char eqv[LNM$C_NAMLENGTH+1] = "";
9497 unsigned int len, tabct = 8, tabidx = 0;
9498 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9499 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9500 unsigned short int dummy, rlen;
9501 struct dsc$descriptor_s **tabvec;
9502 #if defined(PERL_IMPLICIT_CONTEXT)
9505 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
9506 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
9507 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9510 #ifdef KILL_BY_SIGPRC
9511 Perl_csighandler_init();
9514 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9515 /* This was moved from the pre-image init handler because on threaded */
9516 /* Perl it was always returning 0 for the default value. */
9517 status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9520 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9523 initial = decc$feature_get_value(s, 4);
9525 /* initial is: 0 if nothing has set the feature */
9526 /* -1 if initialized to default */
9527 /* 1 if set by logical name */
9528 /* 2 if set by decc$feature_set_value */
9529 decc_disable_posix_root = decc$feature_get_value(s, 1);
9531 /* If the value is not valid, force the feature off */
9532 if (decc_disable_posix_root < 0) {
9533 decc$feature_set_value(s, 1, 1);
9534 decc_disable_posix_root = 1;
9538 /* Nothing has asked for it explicitly, so use our own default. */
9539 decc_disable_posix_root = 1;
9540 decc$feature_set_value(s, 1, 1);
9546 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9547 _ckvmssts_noperl(iosb[0]);
9548 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9549 if (iprv[i]) { /* Running image installed with privs? */
9550 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
9555 /* Rights identifiers might trigger tainting as well. */
9556 if (!will_taint && (rlen || rsz)) {
9557 while (rlen < rsz) {
9558 /* We didn't get all the identifiers on the first pass. Allocate a
9559 * buffer much larger than $GETJPI wants (rsz is size in bytes that
9560 * were needed to hold all identifiers at time of last call; we'll
9561 * allocate that many unsigned long ints), and go back and get 'em.
9562 * If it gave us less than it wanted to despite ample buffer space,
9563 * something's broken. Is your system missing a system identifier?
9565 if (rsz <= jpilist[1].buflen) {
9566 /* Perl_croak accvios when used this early in startup. */
9567 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9568 rsz, (unsigned long) jpilist[1].buflen,
9569 "Check your rights database for corruption.\n");
9572 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9573 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9574 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9575 jpilist[1].buflen = rsz * sizeof(unsigned long int);
9576 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9577 _ckvmssts_noperl(iosb[0]);
9579 mask = (unsigned long int *)jpilist[1].bufadr;
9580 /* Check attribute flags for each identifier (2nd longword); protected
9581 * subsystem identifiers trigger tainting.
9583 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9584 if (mask[i] & KGB$M_SUBSYSTEM) {
9589 if (mask != rlst) PerlMem_free(mask);
9592 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9593 * logical, some versions of the CRTL will add a phanthom /000000/
9594 * directory. This needs to be removed.
9596 if (decc_filename_unix_report) {
9599 ulen = strlen(argvp[0][0]);
9601 zeros = strstr(argvp[0][0], "/000000/");
9602 if (zeros != NULL) {
9604 mlen = ulen - (zeros - argvp[0][0]) - 7;
9605 memmove(zeros, &zeros[7], mlen);
9607 argvp[0][0][ulen] = '\0';
9610 /* It also may have a trailing dot that needs to be removed otherwise
9611 * it will be converted to VMS mode incorrectly.
9614 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9615 argvp[0][0][ulen] = '\0';
9618 /* We need to use this hack to tell Perl it should run with tainting,
9619 * since its tainting flag may be part of the PL_curinterp struct, which
9620 * hasn't been allocated when vms_image_init() is called.
9623 char **newargv, **oldargv;
9625 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9626 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9627 newargv[0] = oldargv[0];
9628 newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9629 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9630 strcpy(newargv[1], "-T");
9631 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9633 newargv[*argcp] = NULL;
9634 /* We orphan the old argv, since we don't know where it's come from,
9635 * so we don't know how to free it.
9639 else { /* Did user explicitly request tainting? */
9641 char *cp, **av = *argvp;
9642 for (i = 1; i < *argcp; i++) {
9643 if (*av[i] != '-') break;
9644 for (cp = av[i]+1; *cp; cp++) {
9645 if (*cp == 'T') { will_taint = 1; break; }
9646 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9647 strchr("DFIiMmx",*cp)) break;
9649 if (will_taint) break;
9654 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9657 tabvec = (struct dsc$descriptor_s **)
9658 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9659 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9661 else if (tabidx >= tabct) {
9663 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9664 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9666 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9667 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9668 tabvec[tabidx]->dsc$w_length = 0;
9669 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9670 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9671 tabvec[tabidx]->dsc$a_pointer = NULL;
9672 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9674 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9676 getredirection(argcp,argvp);
9677 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9679 # include <reentrancy.h>
9680 decc$set_reentrancy(C$C_MULTITHREAD);
9689 * Trim Unix-style prefix off filespec, so it looks like what a shell
9690 * glob expansion would return (i.e. from specified prefix on, not
9691 * full path). Note that returned filespec is Unix-style, regardless
9692 * of whether input filespec was VMS-style or Unix-style.
9694 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9695 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9696 * vector of options; at present, only bit 0 is used, and if set tells
9697 * trim unixpath to try the current default directory as a prefix when
9698 * presented with a possibly ambiguous ... wildcard.
9700 * Returns !=0 on success, with trimmed filespec replacing contents of
9701 * fspec, and 0 on failure, with contents of fpsec unchanged.
9703 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9705 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9707 char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9708 register int tmplen, reslen = 0, dirs = 0;
9710 if (!wildspec || !fspec) return 0;
9712 unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9713 if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9715 if (strpbrk(wildspec,"]>:") != NULL) {
9716 if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9717 PerlMem_free(unixwild);
9722 my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9724 unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9725 if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9726 if (strpbrk(fspec,"]>:") != NULL) {
9727 if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9728 PerlMem_free(unixwild);
9729 PerlMem_free(unixified);
9732 else base = unixified;
9733 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9734 * check to see that final result fits into (isn't longer than) fspec */
9735 reslen = strlen(fspec);
9739 /* No prefix or absolute path on wildcard, so nothing to remove */
9740 if (!*tplate || *tplate == '/') {
9741 PerlMem_free(unixwild);
9742 if (base == fspec) {
9743 PerlMem_free(unixified);
9746 tmplen = strlen(unixified);
9747 if (tmplen > reslen) {
9748 PerlMem_free(unixified);
9749 return 0; /* not enough space */
9751 /* Copy unixified resultant, including trailing NUL */
9752 memmove(fspec,unixified,tmplen+1);
9753 PerlMem_free(unixified);
9757 for (end = base; *end; end++) ; /* Find end of resultant filespec */
9758 if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9759 for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9760 for (cp1 = end ;cp1 >= base; cp1--)
9761 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9763 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9764 PerlMem_free(unixified);
9765 PerlMem_free(unixwild);
9770 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9771 int ells = 1, totells, segdirs, match;
9772 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9773 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9775 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9777 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9778 tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9779 if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9780 if (ellipsis == tplate && opts & 1) {
9781 /* Template begins with an ellipsis. Since we can't tell how many
9782 * directory names at the front of the resultant to keep for an
9783 * arbitrary starting point, we arbitrarily choose the current
9784 * default directory as a starting point. If it's there as a prefix,
9785 * clip it off. If not, fall through and act as if the leading
9786 * ellipsis weren't there (i.e. return shortest possible path that
9787 * could match template).
9789 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9791 PerlMem_free(unixified);
9792 PerlMem_free(unixwild);
9795 if (!decc_efs_case_preserve) {
9796 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9797 if (_tolower(*cp1) != _tolower(*cp2)) break;
9799 segdirs = dirs - totells; /* Min # of dirs we must have left */
9800 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9801 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9802 memmove(fspec,cp2+1,end - cp2);
9804 PerlMem_free(unixified);
9805 PerlMem_free(unixwild);
9809 /* First off, back up over constant elements at end of path */
9811 for (front = end ; front >= base; front--)
9812 if (*front == '/' && !dirs--) { front++; break; }
9814 lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9815 if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9816 for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9818 if (!decc_efs_case_preserve) {
9819 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9827 PerlMem_free(unixified);
9828 PerlMem_free(unixwild);
9829 PerlMem_free(lcres);
9830 return 0; /* Path too long. */
9833 *cp2 = '\0'; /* Pick up with memcpy later */
9834 lcfront = lcres + (front - base);
9835 /* Now skip over each ellipsis and try to match the path in front of it. */
9837 for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9838 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9839 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
9840 if (cp1 < tplate) break; /* template started with an ellipsis */
9841 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9842 ellipsis = cp1; continue;
9844 wilddsc.dsc$a_pointer = tpl;
9845 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9847 for (segdirs = 0, cp2 = tpl;
9848 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9850 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9852 if (!decc_efs_case_preserve) {
9853 *cp2 = _tolower(*cp1); /* else lowercase for match */
9856 *cp2 = *cp1; /* else preserve case for match */
9859 if (*cp2 == '/') segdirs++;
9861 if (cp1 != ellipsis - 1) {
9863 PerlMem_free(unixified);
9864 PerlMem_free(unixwild);
9865 PerlMem_free(lcres);
9866 return 0; /* Path too long */
9868 /* Back up at least as many dirs as in template before matching */
9869 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9870 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9871 for (match = 0; cp1 > lcres;) {
9872 resdsc.dsc$a_pointer = cp1;
9873 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9875 if (match == 1) lcfront = cp1;
9877 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9881 PerlMem_free(unixified);
9882 PerlMem_free(unixwild);
9883 PerlMem_free(lcres);
9884 return 0; /* Can't find prefix ??? */
9886 if (match > 1 && opts & 1) {
9887 /* This ... wildcard could cover more than one set of dirs (i.e.
9888 * a set of similar dir names is repeated). If the template
9889 * contains more than 1 ..., upstream elements could resolve the
9890 * ambiguity, but it's not worth a full backtracking setup here.
9891 * As a quick heuristic, clip off the current default directory
9892 * if it's present to find the trimmed spec, else use the
9893 * shortest string that this ... could cover.
9895 char def[NAM$C_MAXRSS+1], *st;
9897 if (getcwd(def, sizeof def,0) == NULL) {
9898 PerlMem_free(unixified);
9899 PerlMem_free(unixwild);
9900 PerlMem_free(lcres);
9904 if (!decc_efs_case_preserve) {
9905 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9906 if (_tolower(*cp1) != _tolower(*cp2)) break;
9908 segdirs = dirs - totells; /* Min # of dirs we must have left */
9909 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9910 if (*cp1 == '\0' && *cp2 == '/') {
9911 memmove(fspec,cp2+1,end - cp2);
9913 PerlMem_free(unixified);
9914 PerlMem_free(unixwild);
9915 PerlMem_free(lcres);
9918 /* Nope -- stick with lcfront from above and keep going. */
9921 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9923 PerlMem_free(unixified);
9924 PerlMem_free(unixwild);
9925 PerlMem_free(lcres);
9929 } /* end of trim_unixpath() */
9934 * VMS readdir() routines.
9935 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9937 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
9938 * Minor modifications to original routines.
9941 /* readdir may have been redefined by reentr.h, so make sure we get
9942 * the local version for what we do here.
9947 #if !defined(PERL_IMPLICIT_CONTEXT)
9948 # define readdir Perl_readdir
9950 # define readdir(a) Perl_readdir(aTHX_ a)
9953 /* Number of elements in vms_versions array */
9954 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
9957 * Open a directory, return a handle for later use.
9959 /*{{{ DIR *opendir(char*name) */
9961 Perl_opendir(pTHX_ const char *name)
9967 Newx(dir, VMS_MAXRSS, char);
9968 if (int_tovmspath(name, dir, NULL) == NULL) {
9972 /* Check access before stat; otherwise stat does not
9973 * accurately report whether it's a directory.
9975 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9976 /* cando_by_name has already set errno */
9980 if (flex_stat(dir,&sb) == -1) return NULL;
9981 if (!S_ISDIR(sb.st_mode)) {
9983 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
9986 /* Get memory for the handle, and the pattern. */
9988 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9990 /* Fill in the fields; mainly playing with the descriptor. */
9991 sprintf(dd->pattern, "%s*.*",dir);
9996 /* By saying we always want the result of readdir() in unix format, we
9997 * are really saying we want all the escapes removed. Otherwise the caller,
9998 * having no way to know whether it's already in VMS format, might send it
9999 * through tovmsspec again, thus double escaping.
10001 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10002 dd->pat.dsc$a_pointer = dd->pattern;
10003 dd->pat.dsc$w_length = strlen(dd->pattern);
10004 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10005 dd->pat.dsc$b_class = DSC$K_CLASS_S;
10006 #if defined(USE_ITHREADS)
10007 Newx(dd->mutex,1,perl_mutex);
10008 MUTEX_INIT( (perl_mutex *) dd->mutex );
10014 } /* end of opendir() */
10018 * Set the flag to indicate we want versions or not.
10020 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10022 vmsreaddirversions(DIR *dd, int flag)
10025 dd->flags |= PERL_VMSDIR_M_VERSIONS;
10027 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10032 * Free up an opened directory.
10034 /*{{{ void closedir(DIR *dd)*/
10036 Perl_closedir(DIR *dd)
10040 sts = lib$find_file_end(&dd->context);
10041 Safefree(dd->pattern);
10042 #if defined(USE_ITHREADS)
10043 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10044 Safefree(dd->mutex);
10051 * Collect all the version numbers for the current file.
10054 collectversions(pTHX_ DIR *dd)
10056 struct dsc$descriptor_s pat;
10057 struct dsc$descriptor_s res;
10059 char *p, *text, *buff;
10061 unsigned long context, tmpsts;
10063 /* Convenient shorthand. */
10066 /* Add the version wildcard, ignoring the "*.*" put on before */
10067 i = strlen(dd->pattern);
10068 Newx(text,i + e->d_namlen + 3,char);
10069 my_strlcpy(text, dd->pattern, i + 1);
10070 sprintf(&text[i - 3], "%s;*", e->d_name);
10072 /* Set up the pattern descriptor. */
10073 pat.dsc$a_pointer = text;
10074 pat.dsc$w_length = i + e->d_namlen - 1;
10075 pat.dsc$b_dtype = DSC$K_DTYPE_T;
10076 pat.dsc$b_class = DSC$K_CLASS_S;
10078 /* Set up result descriptor. */
10079 Newx(buff, VMS_MAXRSS, char);
10080 res.dsc$a_pointer = buff;
10081 res.dsc$w_length = VMS_MAXRSS - 1;
10082 res.dsc$b_dtype = DSC$K_DTYPE_T;
10083 res.dsc$b_class = DSC$K_CLASS_S;
10085 /* Read files, collecting versions. */
10086 for (context = 0, e->vms_verscount = 0;
10087 e->vms_verscount < VERSIZE(e);
10088 e->vms_verscount++) {
10089 unsigned long rsts;
10090 unsigned long flags = 0;
10092 #ifdef VMS_LONGNAME_SUPPORT
10093 flags = LIB$M_FIL_LONG_NAMES;
10095 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10096 if (tmpsts == RMS$_NMF || context == 0) break;
10098 buff[VMS_MAXRSS - 1] = '\0';
10099 if ((p = strchr(buff, ';')))
10100 e->vms_versions[e->vms_verscount] = atoi(p + 1);
10102 e->vms_versions[e->vms_verscount] = -1;
10105 _ckvmssts(lib$find_file_end(&context));
10109 } /* end of collectversions() */
10112 * Read the next entry from the directory.
10114 /*{{{ struct dirent *readdir(DIR *dd)*/
10116 Perl_readdir(pTHX_ DIR *dd)
10118 struct dsc$descriptor_s res;
10120 unsigned long int tmpsts;
10121 unsigned long rsts;
10122 unsigned long flags = 0;
10123 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10124 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10126 /* Set up result descriptor, and get next file. */
10127 Newx(buff, VMS_MAXRSS, char);
10128 res.dsc$a_pointer = buff;
10129 res.dsc$w_length = VMS_MAXRSS - 1;
10130 res.dsc$b_dtype = DSC$K_DTYPE_T;
10131 res.dsc$b_class = DSC$K_CLASS_S;
10133 #ifdef VMS_LONGNAME_SUPPORT
10134 flags = LIB$M_FIL_LONG_NAMES;
10137 tmpsts = lib$find_file
10138 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10139 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
10140 if (!(tmpsts & 1)) {
10141 set_vaxc_errno(tmpsts);
10144 set_errno(EACCES); break;
10146 set_errno(ENODEV); break;
10148 set_errno(ENOTDIR); break;
10149 case RMS$_FNF: case RMS$_DNF:
10150 set_errno(ENOENT); break;
10152 set_errno(EVMSERR);
10158 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10159 buff[res.dsc$w_length] = '\0';
10160 p = buff + res.dsc$w_length;
10161 while (--p >= buff) if (!isspace(*p)) break;
10163 if (!decc_efs_case_preserve) {
10164 for (p = buff; *p; p++) *p = _tolower(*p);
10167 /* Skip any directory component and just copy the name. */
10168 sts = vms_split_path
10183 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10185 /* In Unix report mode, remove the ".dir;1" from the name */
10186 /* if it is a real directory. */
10187 if (decc_filename_unix_report || decc_efs_charset) {
10188 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10192 ret_sts = flex_lstat(buff, &statbuf);
10193 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10200 /* Drop NULL extensions on UNIX file specification */
10201 if ((e_len == 1) && decc_readdir_dropdotnotype) {
10207 memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10208 dd->entry.d_name[n_len + e_len] = '\0';
10209 dd->entry.d_namlen = strlen(dd->entry.d_name);
10211 /* Convert the filename to UNIX format if needed */
10212 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10214 /* Translate the encoded characters. */
10215 /* Fixme: Unicode handling could result in embedded 0 characters */
10216 if (strchr(dd->entry.d_name, '^') != NULL) {
10217 char new_name[256];
10219 p = dd->entry.d_name;
10222 int inchars_read, outchars_added;
10223 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10225 q += outchars_added;
10227 /* if outchars_added > 1, then this is a wide file specification */
10228 /* Wide file specifications need to be passed in Perl */
10229 /* counted strings apparently with a Unicode flag */
10232 dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10236 dd->entry.vms_verscount = 0;
10237 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10241 } /* end of readdir() */
10245 * Read the next entry from the directory -- thread-safe version.
10247 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10249 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10253 MUTEX_LOCK( (perl_mutex *) dd->mutex );
10255 entry = readdir(dd);
10257 retval = ( *result == NULL ? errno : 0 );
10259 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10263 } /* end of readdir_r() */
10267 * Return something that can be used in a seekdir later.
10269 /*{{{ long telldir(DIR *dd)*/
10271 Perl_telldir(DIR *dd)
10278 * Return to a spot where we used to be. Brute force.
10280 /*{{{ void seekdir(DIR *dd,long count)*/
10282 Perl_seekdir(pTHX_ DIR *dd, long count)
10286 /* If we haven't done anything yet... */
10287 if (dd->count == 0)
10290 /* Remember some state, and clear it. */
10291 old_flags = dd->flags;
10292 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10293 _ckvmssts(lib$find_file_end(&dd->context));
10296 /* The increment is in readdir(). */
10297 for (dd->count = 0; dd->count < count; )
10300 dd->flags = old_flags;
10302 } /* end of seekdir() */
10305 /* VMS subprocess management
10307 * my_vfork() - just a vfork(), after setting a flag to record that
10308 * the current script is trying a Unix-style fork/exec.
10310 * vms_do_aexec() and vms_do_exec() are called in response to the
10311 * perl 'exec' function. If this follows a vfork call, then they
10312 * call out the regular perl routines in doio.c which do an
10313 * execvp (for those who really want to try this under VMS).
10314 * Otherwise, they do exactly what the perl docs say exec should
10315 * do - terminate the current script and invoke a new command
10316 * (See below for notes on command syntax.)
10318 * do_aspawn() and do_spawn() implement the VMS side of the perl
10319 * 'system' function.
10321 * Note on command arguments to perl 'exec' and 'system': When handled
10322 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10323 * are concatenated to form a DCL command string. If the first non-numeric
10324 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10325 * the command string is handed off to DCL directly. Otherwise,
10326 * the first token of the command is taken as the filespec of an image
10327 * to run. The filespec is expanded using a default type of '.EXE' and
10328 * the process defaults for device, directory, etc., and if found, the resultant
10329 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10330 * the command string as parameters. This is perhaps a bit complicated,
10331 * but I hope it will form a happy medium between what VMS folks expect
10332 * from lib$spawn and what Unix folks expect from exec.
10335 static int vfork_called;
10337 /*{{{int my_vfork(void)*/
10348 vms_execfree(struct dsc$descriptor_s *vmscmd)
10351 if (vmscmd->dsc$a_pointer) {
10352 PerlMem_free(vmscmd->dsc$a_pointer);
10354 PerlMem_free(vmscmd);
10359 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10361 char *junk, *tmps = NULL;
10362 register size_t cmdlen = 0;
10369 tmps = SvPV(really,rlen);
10371 cmdlen += rlen + 1;
10376 for (idx++; idx <= sp; idx++) {
10378 junk = SvPVx(*idx,rlen);
10379 cmdlen += rlen ? rlen + 1 : 0;
10382 Newx(PL_Cmd, cmdlen+1, char);
10384 if (tmps && *tmps) {
10385 my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10388 else *PL_Cmd = '\0';
10389 while (++mark <= sp) {
10391 char *s = SvPVx(*mark,n_a);
10393 if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10394 my_strlcat(PL_Cmd, s, cmdlen+1);
10399 } /* end of setup_argstr() */
10402 static unsigned long int
10403 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10404 struct dsc$descriptor_s **pvmscmd)
10408 char image_name[NAM$C_MAXRSS+1];
10409 char image_argv[NAM$C_MAXRSS+1];
10410 $DESCRIPTOR(defdsc,".EXE");
10411 $DESCRIPTOR(defdsc2,".");
10412 struct dsc$descriptor_s resdsc;
10413 struct dsc$descriptor_s *vmscmd;
10414 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10415 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10416 register char *s, *rest, *cp, *wordbreak;
10419 register int isdcl;
10421 vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10422 if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10424 /* vmsspec is a DCL command buffer, not just a filename */
10425 vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10426 if (vmsspec == NULL)
10427 _ckvmssts_noperl(SS$_INSFMEM);
10429 resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10430 if (resspec == NULL)
10431 _ckvmssts_noperl(SS$_INSFMEM);
10433 /* Make a copy for modification */
10434 cmdlen = strlen(incmd);
10435 cmd = (char *)PerlMem_malloc(cmdlen+1);
10436 if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10437 my_strlcpy(cmd, incmd, cmdlen + 1);
10441 resdsc.dsc$a_pointer = resspec;
10442 resdsc.dsc$b_dtype = DSC$K_DTYPE_T;
10443 resdsc.dsc$b_class = DSC$K_CLASS_S;
10444 resdsc.dsc$w_length = VMS_MAXRSS - 1;
10446 vmscmd->dsc$a_pointer = NULL;
10447 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
10448 vmscmd->dsc$b_class = DSC$K_CLASS_S;
10449 vmscmd->dsc$w_length = 0;
10450 if (pvmscmd) *pvmscmd = vmscmd;
10452 if (suggest_quote) *suggest_quote = 0;
10454 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10456 PerlMem_free(vmsspec);
10457 PerlMem_free(resspec);
10458 return CLI$_BUFOVF; /* continuation lines currently unsupported */
10463 while (*s && isspace(*s)) s++;
10465 if (*s == '@' || *s == '$') {
10466 vmsspec[0] = *s; rest = s + 1;
10467 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10469 else { cp = vmsspec; rest = s; }
10470 if (*rest == '.' || *rest == '/') {
10472 for (cp2 = resspec;
10473 *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10474 rest++, cp2++) *cp2 = *rest;
10476 if (int_tovmsspec(resspec, cp, 0, NULL)) {
10479 /* When a UNIX spec with no file type is translated to VMS, */
10480 /* A trailing '.' is appended under ODS-5 rules. */
10481 /* Here we do not want that trailing "." as it prevents */
10482 /* Looking for a implied ".exe" type. */
10483 if (decc_efs_charset) {
10485 i = strlen(vmsspec);
10486 if (vmsspec[i-1] == '.') {
10487 vmsspec[i-1] = '\0';
10492 for (cp2 = vmsspec + strlen(vmsspec);
10493 *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10494 rest++, cp2++) *cp2 = *rest;
10499 /* Intuit whether verb (first word of cmd) is a DCL command:
10500 * - if first nonspace char is '@', it's a DCL indirection
10502 * - if verb contains a filespec separator, it's not a DCL command
10503 * - if it doesn't, caller tells us whether to default to a DCL
10504 * command, or to a local image unless told it's DCL (by leading '$')
10508 if (suggest_quote) *suggest_quote = 1;
10510 register char *filespec = strpbrk(s,":<[.;");
10511 rest = wordbreak = strpbrk(s," \"\t/");
10512 if (!wordbreak) wordbreak = s + strlen(s);
10513 if (*s == '$') check_img = 0;
10514 if (filespec && (filespec < wordbreak)) isdcl = 0;
10515 else isdcl = !check_img;
10520 imgdsc.dsc$a_pointer = s;
10521 imgdsc.dsc$w_length = wordbreak - s;
10522 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10524 _ckvmssts_noperl(lib$find_file_end(&cxt));
10525 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10526 if (!(retsts & 1) && *s == '$') {
10527 _ckvmssts_noperl(lib$find_file_end(&cxt));
10528 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10529 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10531 _ckvmssts_noperl(lib$find_file_end(&cxt));
10532 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10536 _ckvmssts_noperl(lib$find_file_end(&cxt));
10541 while (*s && !isspace(*s)) s++;
10544 /* check that it's really not DCL with no file extension */
10545 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10547 char b[256] = {0,0,0,0};
10548 read(fileno(fp), b, 256);
10549 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10553 /* Check for script */
10555 if ((b[0] == '#') && (b[1] == '!'))
10557 #ifdef ALTERNATE_SHEBANG
10559 shebang_len = strlen(ALTERNATE_SHEBANG);
10560 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10562 perlstr = strstr("perl",b);
10563 if (perlstr == NULL)
10571 if (shebang_len > 0) {
10574 char tmpspec[NAM$C_MAXRSS + 1];
10577 /* Image is following after white space */
10578 /*--------------------------------------*/
10579 while (isprint(b[i]) && isspace(b[i]))
10583 while (isprint(b[i]) && !isspace(b[i])) {
10584 tmpspec[j++] = b[i++];
10585 if (j >= NAM$C_MAXRSS)
10590 /* There may be some default parameters to the image */
10591 /*---------------------------------------------------*/
10593 while (isprint(b[i])) {
10594 image_argv[j++] = b[i++];
10595 if (j >= NAM$C_MAXRSS)
10598 while ((j > 0) && !isprint(image_argv[j-1]))
10602 /* It will need to be converted to VMS format and validated */
10603 if (tmpspec[0] != '\0') {
10606 /* Try to find the exact program requested to be run */
10607 /*---------------------------------------------------*/
10608 iname = int_rmsexpand
10609 (tmpspec, image_name, ".exe",
10610 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10611 if (iname != NULL) {
10612 if (cando_by_name_int
10613 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10614 /* MCR prefix needed */
10618 /* Try again with a null type */
10619 /*----------------------------*/
10620 iname = int_rmsexpand
10621 (tmpspec, image_name, ".",
10622 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10623 if (iname != NULL) {
10624 if (cando_by_name_int
10625 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10626 /* MCR prefix needed */
10632 /* Did we find the image to run the script? */
10633 /*------------------------------------------*/
10637 /* Assume DCL or foreign command exists */
10638 /*--------------------------------------*/
10639 tchr = strrchr(tmpspec, '/');
10640 if (tchr != NULL) {
10646 my_strlcpy(image_name, tchr, sizeof(image_name));
10654 if (check_img && isdcl) {
10656 PerlMem_free(resspec);
10657 PerlMem_free(vmsspec);
10661 if (cando_by_name(S_IXUSR,0,resspec)) {
10662 vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10663 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10665 my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10666 if (image_name[0] != 0) {
10667 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10668 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10670 } else if (image_name[0] != 0) {
10671 my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10672 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10674 my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10676 if (suggest_quote) *suggest_quote = 1;
10678 /* If there is an image name, use original command */
10679 if (image_name[0] == 0)
10680 my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10683 while (*rest && isspace(*rest)) rest++;
10686 if (image_argv[0] != 0) {
10687 my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10688 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10694 rest_len = strlen(rest);
10695 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10696 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10697 my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10699 retsts = CLI$_BUFOVF;
10701 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10703 PerlMem_free(vmsspec);
10704 PerlMem_free(resspec);
10705 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10711 /* It's either a DCL command or we couldn't find a suitable image */
10712 vmscmd->dsc$w_length = strlen(cmd);
10714 vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10715 my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10718 PerlMem_free(resspec);
10719 PerlMem_free(vmsspec);
10721 /* check if it's a symbol (for quoting purposes) */
10722 if (suggest_quote && !*suggest_quote) {
10724 char equiv[LNM$C_NAMLENGTH];
10725 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10726 eqvdsc.dsc$a_pointer = equiv;
10728 iss = lib$get_symbol(vmscmd,&eqvdsc);
10729 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10731 if (!(retsts & 1)) {
10732 /* just hand off status values likely to be due to user error */
10733 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10734 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10735 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10736 else { _ckvmssts_noperl(retsts); }
10739 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10741 } /* end of setup_cmddsc() */
10744 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10746 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10752 if (vfork_called) { /* this follows a vfork - act Unixish */
10754 if (vfork_called < 0) {
10755 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10758 else return do_aexec(really,mark,sp);
10760 /* no vfork - act VMSish */
10761 cmd = setup_argstr(aTHX_ really,mark,sp);
10762 exec_sts = vms_do_exec(cmd);
10763 Safefree(cmd); /* Clean up from setup_argstr() */
10768 } /* end of vms_do_aexec() */
10771 /* {{{bool vms_do_exec(char *cmd) */
10773 Perl_vms_do_exec(pTHX_ const char *cmd)
10775 struct dsc$descriptor_s *vmscmd;
10777 if (vfork_called) { /* this follows a vfork - act Unixish */
10779 if (vfork_called < 0) {
10780 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10783 else return do_exec(cmd);
10786 { /* no vfork - act VMSish */
10787 unsigned long int retsts;
10790 TAINT_PROPER("exec");
10791 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10792 retsts = lib$do_command(vmscmd);
10795 case RMS$_FNF: case RMS$_DNF:
10796 set_errno(ENOENT); break;
10798 set_errno(ENOTDIR); break;
10800 set_errno(ENODEV); break;
10802 set_errno(EACCES); break;
10804 set_errno(EINVAL); break;
10805 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10806 set_errno(E2BIG); break;
10807 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10808 _ckvmssts_noperl(retsts); /* fall through */
10809 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10810 set_errno(EVMSERR);
10812 set_vaxc_errno(retsts);
10813 if (ckWARN(WARN_EXEC)) {
10814 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10815 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10817 vms_execfree(vmscmd);
10822 } /* end of vms_do_exec() */
10825 int do_spawn2(pTHX_ const char *, int);
10828 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10830 unsigned long int sts;
10836 /* We'll copy the (undocumented?) Win32 behavior and allow a
10837 * numeric first argument. But the only value we'll support
10838 * through do_aspawn is a value of 1, which means spawn without
10839 * waiting for completion -- other values are ignored.
10841 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10843 flags = SvIVx(*mark);
10846 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
10847 flags = CLI$M_NOWAIT;
10851 cmd = setup_argstr(aTHX_ really, mark, sp);
10852 sts = do_spawn2(aTHX_ cmd, flags);
10853 /* pp_sys will clean up cmd */
10857 } /* end of do_aspawn() */
10861 /* {{{int do_spawn(char* cmd) */
10863 Perl_do_spawn(pTHX_ char* cmd)
10865 PERL_ARGS_ASSERT_DO_SPAWN;
10867 return do_spawn2(aTHX_ cmd, 0);
10871 /* {{{int do_spawn_nowait(char* cmd) */
10873 Perl_do_spawn_nowait(pTHX_ char* cmd)
10875 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10877 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10881 /* {{{int do_spawn2(char *cmd) */
10883 do_spawn2(pTHX_ const char *cmd, int flags)
10885 unsigned long int sts, substs;
10887 /* The caller of this routine expects to Safefree(PL_Cmd) */
10888 Newx(PL_Cmd,10,char);
10891 TAINT_PROPER("spawn");
10892 if (!cmd || !*cmd) {
10893 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10896 case RMS$_FNF: case RMS$_DNF:
10897 set_errno(ENOENT); break;
10899 set_errno(ENOTDIR); break;
10901 set_errno(ENODEV); break;
10903 set_errno(EACCES); break;
10905 set_errno(EINVAL); break;
10906 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10907 set_errno(E2BIG); break;
10908 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10909 _ckvmssts_noperl(sts); /* fall through */
10910 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10911 set_errno(EVMSERR);
10913 set_vaxc_errno(sts);
10914 if (ckWARN(WARN_EXEC)) {
10915 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10924 if (flags & CLI$M_NOWAIT)
10927 strcpy(mode, "nW");
10929 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10932 /* sts will be the pid in the nowait case */
10935 } /* end of do_spawn2() */
10939 static unsigned int *sockflags, sockflagsize;
10942 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10943 * routines found in some versions of the CRTL can't deal with sockets.
10944 * We don't shim the other file open routines since a socket isn't
10945 * likely to be opened by a name.
10947 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10948 FILE *my_fdopen(int fd, const char *mode)
10950 FILE *fp = fdopen(fd, mode);
10953 unsigned int fdoff = fd / sizeof(unsigned int);
10954 Stat_t sbuf; /* native stat; we don't need flex_stat */
10955 if (!sockflagsize || fdoff > sockflagsize) {
10956 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
10957 else Newx (sockflags,fdoff+2,unsigned int);
10958 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10959 sockflagsize = fdoff + 2;
10961 if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
10962 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10971 * Clear the corresponding bit when the (possibly) socket stream is closed.
10972 * There still a small hole: we miss an implicit close which might occur
10973 * via freopen(). >> Todo
10975 /*{{{ int my_fclose(FILE *fp)*/
10976 int my_fclose(FILE *fp) {
10978 unsigned int fd = fileno(fp);
10979 unsigned int fdoff = fd / sizeof(unsigned int);
10981 if (sockflagsize && fdoff < sockflagsize)
10982 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10990 * A simple fwrite replacement which outputs itmsz*nitm chars without
10991 * introducing record boundaries every itmsz chars.
10992 * We are using fputs, which depends on a terminating null. We may
10993 * well be writing binary data, so we need to accommodate not only
10994 * data with nulls sprinkled in the middle but also data with no null
10997 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10999 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11001 register char *cp, *end, *cpd;
11003 register unsigned int fd = fileno(dest);
11004 register unsigned int fdoff = fd / sizeof(unsigned int);
11006 int bufsize = itmsz * nitm + 1;
11008 if (fdoff < sockflagsize &&
11009 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11010 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11014 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11015 memcpy( data, src, itmsz*nitm );
11016 data[itmsz*nitm] = '\0';
11018 end = data + itmsz * nitm;
11019 retval = (int) nitm; /* on success return # items written */
11022 while (cpd <= end) {
11023 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11024 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11026 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11030 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11033 } /* end of my_fwrite() */
11036 /*{{{ int my_flush(FILE *fp)*/
11038 Perl_my_flush(pTHX_ FILE *fp)
11041 if ((res = fflush(fp)) == 0 && fp) {
11042 #ifdef VMS_DO_SOCKETS
11044 if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11046 res = fsync(fileno(fp));
11049 * If the flush succeeded but set end-of-file, we need to clear
11050 * the error because our caller may check ferror(). BTW, this
11051 * probably means we just flushed an empty file.
11053 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11059 /* fgetname() is not returning the correct file specifications when
11060 * decc_filename_unix_report mode is active. So we have to have it
11061 * aways return filenames in VMS mode and convert it ourselves.
11064 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11066 Perl_my_fgetname(FILE *fp, char * buf) {
11070 retname = fgetname(fp, buf, 1);
11072 /* If we are in VMS mode, then we are done */
11073 if (!decc_filename_unix_report || (retname == NULL)) {
11077 /* Convert this to Unix format */
11078 vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11079 my_strlcpy(vms_name, retname, VMS_MAXRSS);
11080 retname = int_tounixspec(vms_name, buf, NULL);
11081 PerlMem_free(vms_name);
11088 * Here are replacements for the following Unix routines in the VMS environment:
11089 * getpwuid Get information for a particular UIC or UID
11090 * getpwnam Get information for a named user
11091 * getpwent Get information for each user in the rights database
11092 * setpwent Reset search to the start of the rights database
11093 * endpwent Finish searching for users in the rights database
11095 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11096 * (defined in pwd.h), which contains the following fields:-
11098 * char *pw_name; Username (in lower case)
11099 * char *pw_passwd; Hashed password
11100 * unsigned int pw_uid; UIC
11101 * unsigned int pw_gid; UIC group number
11102 * char *pw_unixdir; Default device/directory (VMS-style)
11103 * char *pw_gecos; Owner name
11104 * char *pw_dir; Default device/directory (Unix-style)
11105 * char *pw_shell; Default CLI name (eg. DCL)
11107 * If the specified user does not exist, getpwuid and getpwnam return NULL.
11109 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11110 * not the UIC member number (eg. what's returned by getuid()),
11111 * getpwuid() can accept either as input (if uid is specified, the caller's
11112 * UIC group is used), though it won't recognise gid=0.
11114 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11115 * information about other users in your group or in other groups, respectively.
11116 * If the required privilege is not available, then these routines fill only
11117 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11120 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11123 /* sizes of various UAF record fields */
11124 #define UAI$S_USERNAME 12
11125 #define UAI$S_IDENT 31
11126 #define UAI$S_OWNER 31
11127 #define UAI$S_DEFDEV 31
11128 #define UAI$S_DEFDIR 63
11129 #define UAI$S_DEFCLI 31
11130 #define UAI$S_PWD 8
11132 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
11133 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11134 (uic).uic$v_group != UIC$K_WILD_GROUP)
11136 static char __empty[]= "";
11137 static struct passwd __passwd_empty=
11138 {(char *) __empty, (char *) __empty, 0, 0,
11139 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11140 static int contxt= 0;
11141 static struct passwd __pwdcache;
11142 static char __pw_namecache[UAI$S_IDENT+1];
11145 * This routine does most of the work extracting the user information.
11147 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11150 unsigned char length;
11151 char pw_gecos[UAI$S_OWNER+1];
11153 static union uicdef uic;
11155 unsigned char length;
11156 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11159 unsigned char length;
11160 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11163 unsigned char length;
11164 char pw_shell[UAI$S_DEFCLI+1];
11166 static char pw_passwd[UAI$S_PWD+1];
11168 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11169 struct dsc$descriptor_s name_desc;
11170 unsigned long int sts;
11172 static struct itmlst_3 itmlst[]= {
11173 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
11174 {sizeof(uic), UAI$_UIC, &uic, &luic},
11175 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
11176 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
11177 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
11178 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
11179 {0, 0, NULL, NULL}};
11181 name_desc.dsc$w_length= strlen(name);
11182 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11183 name_desc.dsc$b_class= DSC$K_CLASS_S;
11184 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11186 /* Note that sys$getuai returns many fields as counted strings. */
11187 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11188 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11189 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11191 else { _ckvmssts(sts); }
11192 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
11194 if ((int) owner.length < lowner) lowner= (int) owner.length;
11195 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11196 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11197 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11198 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11199 owner.pw_gecos[lowner]= '\0';
11200 defdev.pw_dir[ldefdev+ldefdir]= '\0';
11201 defcli.pw_shell[ldefcli]= '\0';
11202 if (valid_uic(uic)) {
11203 pwd->pw_uid= uic.uic$l_uic;
11204 pwd->pw_gid= uic.uic$v_group;
11207 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11208 pwd->pw_passwd= pw_passwd;
11209 pwd->pw_gecos= owner.pw_gecos;
11210 pwd->pw_dir= defdev.pw_dir;
11211 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11212 pwd->pw_shell= defcli.pw_shell;
11213 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11215 ldir= strlen(pwd->pw_unixdir) - 1;
11216 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11219 my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11220 if (!decc_efs_case_preserve)
11221 __mystrtolower(pwd->pw_unixdir);
11226 * Get information for a named user.
11228 /*{{{struct passwd *getpwnam(char *name)*/
11229 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11231 struct dsc$descriptor_s name_desc;
11233 unsigned long int sts;
11235 __pwdcache = __passwd_empty;
11236 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11237 /* We still may be able to determine pw_uid and pw_gid */
11238 name_desc.dsc$w_length= strlen(name);
11239 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11240 name_desc.dsc$b_class= DSC$K_CLASS_S;
11241 name_desc.dsc$a_pointer= (char *) name;
11242 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11243 __pwdcache.pw_uid= uic.uic$l_uic;
11244 __pwdcache.pw_gid= uic.uic$v_group;
11247 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11248 set_vaxc_errno(sts);
11249 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11252 else { _ckvmssts(sts); }
11255 my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11256 __pwdcache.pw_name= __pw_namecache;
11257 return &__pwdcache;
11258 } /* end of my_getpwnam() */
11262 * Get information for a particular UIC or UID.
11263 * Called by my_getpwent with uid=-1 to list all users.
11265 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11266 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11268 const $DESCRIPTOR(name_desc,__pw_namecache);
11269 unsigned short lname;
11271 unsigned long int status;
11273 if (uid == (unsigned int) -1) {
11275 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11276 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11277 set_vaxc_errno(status);
11278 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11282 else { _ckvmssts(status); }
11283 } while (!valid_uic (uic));
11286 uic.uic$l_uic= uid;
11287 if (!uic.uic$v_group)
11288 uic.uic$v_group= PerlProc_getgid();
11289 if (valid_uic(uic))
11290 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11291 else status = SS$_IVIDENT;
11292 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11293 status == RMS$_PRV) {
11294 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11297 else { _ckvmssts(status); }
11299 __pw_namecache[lname]= '\0';
11300 __mystrtolower(__pw_namecache);
11302 __pwdcache = __passwd_empty;
11303 __pwdcache.pw_name = __pw_namecache;
11305 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11306 The identifier's value is usually the UIC, but it doesn't have to be,
11307 so if we can, we let fillpasswd update this. */
11308 __pwdcache.pw_uid = uic.uic$l_uic;
11309 __pwdcache.pw_gid = uic.uic$v_group;
11311 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11312 return &__pwdcache;
11314 } /* end of my_getpwuid() */
11318 * Get information for next user.
11320 /*{{{struct passwd *my_getpwent()*/
11321 struct passwd *Perl_my_getpwent(pTHX)
11323 return (my_getpwuid((unsigned int) -1));
11328 * Finish searching rights database for users.
11330 /*{{{void my_endpwent()*/
11331 void Perl_my_endpwent(pTHX)
11334 _ckvmssts(sys$finish_rdb(&contxt));
11340 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11341 * my_utime(), and flex_stat(), all of which operate on UTC unless
11342 * VMSISH_TIMES is true.
11344 /* method used to handle UTC conversions:
11345 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
11347 static int gmtime_emulation_type;
11348 /* number of secs to add to UTC POSIX-style time to get local time */
11349 static long int utc_offset_secs;
11351 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11352 * in vmsish.h. #undef them here so we can call the CRTL routines
11360 static time_t toutc_dst(time_t loc) {
11363 if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11364 loc -= utc_offset_secs;
11365 if (rsltmp->tm_isdst) loc -= 3600;
11368 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11369 ((gmtime_emulation_type || my_time(NULL)), \
11370 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11371 ((secs) - utc_offset_secs))))
11373 static time_t toloc_dst(time_t utc) {
11376 utc += utc_offset_secs;
11377 if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11378 if (rsltmp->tm_isdst) utc += 3600;
11381 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11382 ((gmtime_emulation_type || my_time(NULL)), \
11383 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11384 ((secs) + utc_offset_secs))))
11386 /* my_time(), my_localtime(), my_gmtime()
11387 * By default traffic in UTC time values, using CRTL gmtime() or
11388 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11389 * Note: We need to use these functions even when the CRTL has working
11390 * UTC support, since they also handle C<use vmsish qw(times);>
11392 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
11393 * Modified by Charles Bailey <bailey@newman.upenn.edu>
11396 /*{{{time_t my_time(time_t *timep)*/
11397 time_t Perl_my_time(pTHX_ time_t *timep)
11402 if (gmtime_emulation_type == 0) {
11403 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11404 /* results of calls to gmtime() and localtime() */
11405 /* for same &base */
11407 gmtime_emulation_type++;
11408 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11409 char off[LNM$C_NAMLENGTH+1];;
11411 gmtime_emulation_type++;
11412 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11413 gmtime_emulation_type++;
11414 utc_offset_secs = 0;
11415 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11417 else { utc_offset_secs = atol(off); }
11419 else { /* We've got a working gmtime() */
11420 struct tm gmt, local;
11423 tm_p = localtime(&base);
11425 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11426 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11427 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11428 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11433 # ifdef VMSISH_TIME
11434 if (VMSISH_TIME) when = _toloc(when);
11436 if (timep != NULL) *timep = when;
11439 } /* end of my_time() */
11443 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11445 Perl_my_gmtime(pTHX_ const time_t *timep)
11450 if (timep == NULL) {
11451 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11454 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11457 # ifdef VMSISH_TIME
11458 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11460 return gmtime(&when);
11461 } /* end of my_gmtime() */
11465 /*{{{struct tm *my_localtime(const time_t *timep)*/
11467 Perl_my_localtime(pTHX_ const time_t *timep)
11471 if (timep == NULL) {
11472 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11475 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11476 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11479 # ifdef VMSISH_TIME
11480 if (VMSISH_TIME) when = _toutc(when);
11482 /* CRTL localtime() wants UTC as input, does tz correction itself */
11483 return localtime(&when);
11484 } /* end of my_localtime() */
11487 /* Reset definitions for later calls */
11488 #define gmtime(t) my_gmtime(t)
11489 #define localtime(t) my_localtime(t)
11490 #define time(t) my_time(t)
11493 /* my_utime - update modification/access time of a file
11495 * VMS 7.3 and later implementation
11496 * Only the UTC translation is home-grown. The rest is handled by the
11497 * CRTL utime(), which will take into account the relevant feature
11498 * logicals and ODS-5 volume characteristics for true access times.
11500 * pre VMS 7.3 implementation:
11501 * The calling sequence is identical to POSIX utime(), but under
11502 * VMS with ODS-2, only the modification time is changed; ODS-2 does
11503 * not maintain access times. Restrictions differ from the POSIX
11504 * definition in that the time can be changed as long as the
11505 * caller has permission to execute the necessary IO$_MODIFY $QIO;
11506 * no separate checks are made to insure that the caller is the
11507 * owner of the file or has special privs enabled.
11508 * Code here is based on Joe Meadows' FILE utility.
11512 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11513 * to VMS epoch (01-JAN-1858 00:00:00.00)
11514 * in 100 ns intervals.
11516 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11518 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11519 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11521 #if __CRTL_VER >= 70300000
11522 struct utimbuf utc_utimes, *utc_utimesp;
11524 if (utimes != NULL) {
11525 utc_utimes.actime = utimes->actime;
11526 utc_utimes.modtime = utimes->modtime;
11527 # ifdef VMSISH_TIME
11528 /* If input was local; convert to UTC for sys svc */
11530 utc_utimes.actime = _toutc(utimes->actime);
11531 utc_utimes.modtime = _toutc(utimes->modtime);
11534 utc_utimesp = &utc_utimes;
11537 utc_utimesp = NULL;
11540 return utime(file, utc_utimesp);
11542 #else /* __CRTL_VER < 70300000 */
11546 long int bintime[2], len = 2, lowbit, unixtime,
11547 secscale = 10000000; /* seconds --> 100 ns intervals */
11548 unsigned long int chan, iosb[2], retsts;
11549 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11550 struct FAB myfab = cc$rms_fab;
11551 struct NAM mynam = cc$rms_nam;
11552 #if defined (__DECC) && defined (__VAX)
11553 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11554 * at least through VMS V6.1, which causes a type-conversion warning.
11556 # pragma message save
11557 # pragma message disable cvtdiftypes
11559 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11560 struct fibdef myfib;
11561 #if defined (__DECC) && defined (__VAX)
11562 /* This should be right after the declaration of myatr, but due
11563 * to a bug in VAX DEC C, this takes effect a statement early.
11565 # pragma message restore
11567 /* cast ok for read only parameter */
11568 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11569 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11570 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11572 if (file == NULL || *file == '\0') {
11573 SETERRNO(ENOENT, LIB$_INVARG);
11577 /* Convert to VMS format ensuring that it will fit in 255 characters */
11578 if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11579 SETERRNO(ENOENT, LIB$_INVARG);
11582 if (utimes != NULL) {
11583 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
11584 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11585 * Since time_t is unsigned long int, and lib$emul takes a signed long int
11586 * as input, we force the sign bit to be clear by shifting unixtime right
11587 * one bit, then multiplying by an extra factor of 2 in lib$emul().
11589 lowbit = (utimes->modtime & 1) ? secscale : 0;
11590 unixtime = (long int) utimes->modtime;
11591 # ifdef VMSISH_TIME
11592 /* If input was UTC; convert to local for sys svc */
11593 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11595 unixtime >>= 1; secscale <<= 1;
11596 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11597 if (!(retsts & 1)) {
11598 SETERRNO(EVMSERR, retsts);
11601 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11602 if (!(retsts & 1)) {
11603 SETERRNO(EVMSERR, retsts);
11608 /* Just get the current time in VMS format directly */
11609 retsts = sys$gettim(bintime);
11610 if (!(retsts & 1)) {
11611 SETERRNO(EVMSERR, retsts);
11616 myfab.fab$l_fna = vmsspec;
11617 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11618 myfab.fab$l_nam = &mynam;
11619 mynam.nam$l_esa = esa;
11620 mynam.nam$b_ess = (unsigned char) sizeof esa;
11621 mynam.nam$l_rsa = rsa;
11622 mynam.nam$b_rss = (unsigned char) sizeof rsa;
11623 if (decc_efs_case_preserve)
11624 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11626 /* Look for the file to be affected, letting RMS parse the file
11627 * specification for us as well. I have set errno using only
11628 * values documented in the utime() man page for VMS POSIX.
11630 retsts = sys$parse(&myfab,0,0);
11631 if (!(retsts & 1)) {
11632 set_vaxc_errno(retsts);
11633 if (retsts == RMS$_PRV) set_errno(EACCES);
11634 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11635 else set_errno(EVMSERR);
11638 retsts = sys$search(&myfab,0,0);
11639 if (!(retsts & 1)) {
11640 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11641 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11642 set_vaxc_errno(retsts);
11643 if (retsts == RMS$_PRV) set_errno(EACCES);
11644 else if (retsts == RMS$_FNF) set_errno(ENOENT);
11645 else set_errno(EVMSERR);
11649 devdsc.dsc$w_length = mynam.nam$b_dev;
11650 /* cast ok for read only parameter */
11651 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11653 retsts = sys$assign(&devdsc,&chan,0,0);
11654 if (!(retsts & 1)) {
11655 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11656 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11657 set_vaxc_errno(retsts);
11658 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
11659 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
11660 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
11661 else set_errno(EVMSERR);
11665 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11666 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11668 memset((void *) &myfib, 0, sizeof myfib);
11669 #if defined(__DECC) || defined(__DECCXX)
11670 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11671 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11672 /* This prevents the revision time of the file being reset to the current
11673 * time as a result of our IO$_MODIFY $QIO. */
11674 myfib.fib$l_acctl = FIB$M_NORECORD;
11676 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11677 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11678 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11680 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11681 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11682 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11683 _ckvmssts(sys$dassgn(chan));
11684 if (retsts & 1) retsts = iosb[0];
11685 if (!(retsts & 1)) {
11686 set_vaxc_errno(retsts);
11687 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11688 else set_errno(EVMSERR);
11694 #endif /* #if __CRTL_VER >= 70300000 */
11696 } /* end of my_utime() */
11700 * flex_stat, flex_lstat, flex_fstat
11701 * basic stat, but gets it right when asked to stat
11702 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11705 #ifndef _USE_STD_STAT
11706 /* encode_dev packs a VMS device name string into an integer to allow
11707 * simple comparisons. This can be used, for example, to check whether two
11708 * files are located on the same device, by comparing their encoded device
11709 * names. Even a string comparison would not do, because stat() reuses the
11710 * device name buffer for each call; so without encode_dev, it would be
11711 * necessary to save the buffer and use strcmp (this would mean a number of
11712 * changes to the standard Perl code, to say nothing of what a Perl script
11713 * would have to do.
11715 * The device lock id, if it exists, should be unique (unless perhaps compared
11716 * with lock ids transferred from other nodes). We have a lock id if the disk is
11717 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11718 * device names. Thus we use the lock id in preference, and only if that isn't
11719 * available, do we try to pack the device name into an integer (flagged by
11720 * the sign bit (LOCKID_MASK) being set).
11722 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11723 * name and its encoded form, but it seems very unlikely that we will find
11724 * two files on different disks that share the same encoded device names,
11725 * and even more remote that they will share the same file id (if the test
11726 * is to check for the same file).
11728 * A better method might be to use sys$device_scan on the first call, and to
11729 * search for the device, returning an index into the cached array.
11730 * The number returned would be more intelligible.
11731 * This is probably not worth it, and anyway would take quite a bit longer
11732 * on the first call.
11734 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
11735 static mydev_t encode_dev (pTHX_ const char *dev)
11738 unsigned long int f;
11743 if (!dev || !dev[0]) return 0;
11747 struct dsc$descriptor_s dev_desc;
11748 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11750 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11751 can try that first. */
11752 dev_desc.dsc$w_length = strlen (dev);
11753 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11754 dev_desc.dsc$b_class = DSC$K_CLASS_S;
11755 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
11756 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11757 if (!$VMS_STATUS_SUCCESS(status)) {
11759 case SS$_NOSUCHDEV:
11760 SETERRNO(ENODEV, status);
11766 if (lockid) return (lockid & ~LOCKID_MASK);
11770 /* Otherwise we try to encode the device name */
11774 for (q = dev + strlen(dev); q--; q >= dev) {
11779 else if (isalpha (toupper (*q)))
11780 c= toupper (*q) - 'A' + (char)10;
11782 continue; /* Skip '$'s */
11784 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11786 enc += f * (unsigned long int) c;
11788 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11790 } /* end of encode_dev() */
11791 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11792 device_no = encode_dev(aTHX_ devname)
11794 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11795 device_no = new_dev_no
11799 is_null_device(const char *name)
11801 if (decc_bug_devnull != 0) {
11802 if (strncmp("/dev/null", name, 9) == 0)
11805 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11806 The underscore prefix, controller letter, and unit number are
11807 independently optional; for our purposes, the colon punctuation
11808 is not. The colon can be trailed by optional directory and/or
11809 filename, but two consecutive colons indicates a nodename rather
11810 than a device. [pr] */
11811 if (*name == '_') ++name;
11812 if (tolower(*name++) != 'n') return 0;
11813 if (tolower(*name++) != 'l') return 0;
11814 if (tolower(*name) == 'a') ++name;
11815 if (*name == '0') ++name;
11816 return (*name++ == ':') && (*name != ':');
11820 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11822 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11825 Perl_cando_by_name_int
11826 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11828 char usrname[L_cuserid];
11829 struct dsc$descriptor_s usrdsc =
11830 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11831 char *vmsname = NULL, *fileified = NULL;
11832 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11833 unsigned short int retlen, trnlnm_iter_count;
11834 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11835 union prvdef curprv;
11836 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11837 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11838 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11839 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11840 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11842 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11844 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11846 static int profile_context = -1;
11848 if (!fname || !*fname) return FALSE;
11850 /* Make sure we expand logical names, since sys$check_access doesn't */
11851 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11852 if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11853 if (!strpbrk(fname,"/]>:")) {
11854 my_strlcpy(fileified, fname, VMS_MAXRSS);
11855 trnlnm_iter_count = 0;
11856 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11857 trnlnm_iter_count++;
11858 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11863 vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11864 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11865 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11866 /* Don't know if already in VMS format, so make sure */
11867 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11868 PerlMem_free(fileified);
11869 PerlMem_free(vmsname);
11874 my_strlcpy(vmsname, fname, VMS_MAXRSS);
11877 /* sys$check_access needs a file spec, not a directory spec.
11878 * flex_stat now will handle a null thread context during startup.
11881 retlen = namdsc.dsc$w_length = strlen(vmsname);
11882 if (vmsname[retlen-1] == ']'
11883 || vmsname[retlen-1] == '>'
11884 || vmsname[retlen-1] == ':'
11885 || (!flex_stat_int(vmsname, &st, 1) &&
11886 S_ISDIR(st.st_mode))) {
11888 if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11889 PerlMem_free(fileified);
11890 PerlMem_free(vmsname);
11899 retlen = namdsc.dsc$w_length = strlen(fname);
11900 namdsc.dsc$a_pointer = (char *)fname;
11903 case S_IXUSR: case S_IXGRP: case S_IXOTH:
11904 access = ARM$M_EXECUTE;
11905 flags = CHP$M_READ;
11907 case S_IRUSR: case S_IRGRP: case S_IROTH:
11908 access = ARM$M_READ;
11909 flags = CHP$M_READ | CHP$M_USEREADALL;
11911 case S_IWUSR: case S_IWGRP: case S_IWOTH:
11912 access = ARM$M_WRITE;
11913 flags = CHP$M_READ | CHP$M_WRITE;
11915 case S_IDUSR: case S_IDGRP: case S_IDOTH:
11916 access = ARM$M_DELETE;
11917 flags = CHP$M_READ | CHP$M_WRITE;
11920 if (fileified != NULL)
11921 PerlMem_free(fileified);
11922 if (vmsname != NULL)
11923 PerlMem_free(vmsname);
11927 /* Before we call $check_access, create a user profile with the current
11928 * process privs since otherwise it just uses the default privs from the
11929 * UAF and might give false positives or negatives. This only works on
11930 * VMS versions v6.0 and later since that's when sys$create_user_profile
11931 * became available.
11934 /* get current process privs and username */
11935 _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11936 _ckvmssts_noperl(iosb[0]);
11938 /* find out the space required for the profile */
11939 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11940 &usrprodsc.dsc$w_length,&profile_context));
11942 /* allocate space for the profile and get it filled in */
11943 usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
11944 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11945 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11946 &usrprodsc.dsc$w_length,&profile_context));
11948 /* use the profile to check access to the file; free profile & analyze results */
11949 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11950 PerlMem_free(usrprodsc.dsc$a_pointer);
11951 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11953 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
11954 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11955 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11956 set_vaxc_errno(retsts);
11957 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11958 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11959 else set_errno(ENOENT);
11960 if (fileified != NULL)
11961 PerlMem_free(fileified);
11962 if (vmsname != NULL)
11963 PerlMem_free(vmsname);
11966 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11967 if (fileified != NULL)
11968 PerlMem_free(fileified);
11969 if (vmsname != NULL)
11970 PerlMem_free(vmsname);
11973 _ckvmssts_noperl(retsts);
11975 if (fileified != NULL)
11976 PerlMem_free(fileified);
11977 if (vmsname != NULL)
11978 PerlMem_free(vmsname);
11979 return FALSE; /* Should never get here */
11983 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
11984 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11985 * subset of the applicable information.
11988 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11990 return cando_by_name_int
11991 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11992 } /* end of cando() */
11996 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11998 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12000 return cando_by_name_int(bit, effective, fname, 0);
12002 } /* end of cando_by_name() */
12006 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12008 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12010 if (!fstat(fd, &statbufp->crtl_stat)) {
12012 char *vms_filename;
12013 vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12014 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12016 /* Save name for cando by name in VMS format */
12017 cptr = getname(fd, vms_filename, 1);
12019 /* This should not happen, but just in case */
12020 if (cptr == NULL) {
12021 statbufp->st_devnam[0] = 0;
12024 /* Make sure that the saved name fits in 255 characters */
12025 cptr = int_rmsexpand_vms
12027 statbufp->st_devnam,
12030 statbufp->st_devnam[0] = 0;
12032 PerlMem_free(vms_filename);
12034 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12036 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12038 # ifdef VMSISH_TIME
12040 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12041 statbufp->st_atime = _toloc(statbufp->st_atime);
12042 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12049 } /* end of flex_fstat() */
12053 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12055 char *temp_fspec = NULL;
12056 char *fileified = NULL;
12057 const char *save_spec;
12061 char already_fileified = 0;
12069 if (decc_bug_devnull != 0) {
12070 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12071 memset(statbufp,0,sizeof *statbufp);
12072 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12073 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12074 statbufp->st_uid = 0x00010001;
12075 statbufp->st_gid = 0x0001;
12076 time((time_t *)&statbufp->st_mtime);
12077 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12084 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12086 * If we are in POSIX filespec mode, accept the filename as is.
12088 if (decc_posix_compliant_pathnames == 0) {
12091 /* Try for a simple stat first. If fspec contains a filename without
12092 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12093 * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12094 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12095 * not sea:[wine.dark]., if the latter exists. If the intended target is
12096 * the file with null type, specify this by calling flex_stat() with
12097 * a '.' at the end of fspec.
12100 if (lstat_flag == 0)
12101 retval = stat(fspec, &statbufp->crtl_stat);
12103 retval = lstat(fspec, &statbufp->crtl_stat);
12109 /* In the odd case where we have write but not read access
12110 * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12112 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12113 if (fileified == NULL)
12114 _ckvmssts_noperl(SS$_INSFMEM);
12116 ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12117 if (ret_spec != NULL) {
12118 if (lstat_flag == 0)
12119 retval = stat(fileified, &statbufp->crtl_stat);
12121 retval = lstat(fileified, &statbufp->crtl_stat);
12122 save_spec = fileified;
12123 already_fileified = 1;
12127 if (retval && vms_bug_stat_filename) {
12129 temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12130 if (temp_fspec == NULL)
12131 _ckvmssts_noperl(SS$_INSFMEM);
12133 /* We should try again as a vmsified file specification. */
12135 ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12136 if (ret_spec != NULL) {
12137 if (lstat_flag == 0)
12138 retval = stat(temp_fspec, &statbufp->crtl_stat);
12140 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12141 save_spec = temp_fspec;
12146 /* Last chance - allow multiple dots without EFS CHARSET */
12147 /* The CRTL stat() falls down hard on multi-dot filenames in unix
12148 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12149 * enable it if it isn't already.
12151 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12152 if (!decc_efs_charset && (decc_efs_charset_index > 0))
12153 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12155 if (lstat_flag == 0)
12156 retval = stat(fspec, &statbufp->crtl_stat);
12158 retval = lstat(fspec, &statbufp->crtl_stat);
12160 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12161 if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12162 decc$feature_set_value(decc_efs_charset_index, 1, 0);
12168 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12170 if (lstat_flag == 0)
12171 retval = stat(temp_fspec, &statbufp->crtl_stat);
12173 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12174 save_spec = temp_fspec;
12178 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12179 /* As you were... */
12180 if (!decc_efs_charset)
12181 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12186 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12188 /* If this is an lstat, do not follow the link */
12190 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12192 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12193 /* If we used the efs_hack above, we must also use it here for */
12194 /* perl_cando to work */
12195 if (efs_hack && (decc_efs_charset_index > 0)) {
12196 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12200 /* If we've got a directory, save a fileified, expanded version of it
12201 * in st_devnam. If not a directory, just an expanded version.
12203 if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12204 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12205 if (fileified == NULL)
12206 _ckvmssts_noperl(SS$_INSFMEM);
12208 cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12210 save_spec = fileified;
12213 cptr = int_rmsexpand(save_spec,
12214 statbufp->st_devnam,
12220 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12221 if (efs_hack && (decc_efs_charset_index > 0)) {
12222 decc$feature_set_value(decc_efs_charset, 1, 0);
12226 /* Fix me: If this is NULL then stat found a file, and we could */
12227 /* not convert the specification to VMS - Should never happen */
12229 statbufp->st_devnam[0] = 0;
12231 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12233 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12234 # ifdef VMSISH_TIME
12236 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12237 statbufp->st_atime = _toloc(statbufp->st_atime);
12238 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12242 /* If we were successful, leave errno where we found it */
12243 if (retval == 0) RESTORE_ERRNO;
12245 PerlMem_free(temp_fspec);
12247 PerlMem_free(fileified);
12250 } /* end of flex_stat_int() */
12253 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12255 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12257 return flex_stat_int(fspec, statbufp, 0);
12261 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12263 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12265 return flex_stat_int(fspec, statbufp, 1);
12270 /*{{{char *my_getlogin()*/
12271 /* VMS cuserid == Unix getlogin, except calling sequence */
12275 static char user[L_cuserid];
12276 return cuserid(user);
12281 /* rmscopy - copy a file using VMS RMS routines
12283 * Copies contents and attributes of spec_in to spec_out, except owner
12284 * and protection information. Name and type of spec_in are used as
12285 * defaults for spec_out. The third parameter specifies whether rmscopy()
12286 * should try to propagate timestamps from the input file to the output file.
12287 * If it is less than 0, no timestamps are preserved. If it is 0, then
12288 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12289 * propagated to the output file at creation iff the output file specification
12290 * did not contain an explicit name or type, and the revision date is always
12291 * updated at the end of the copy operation. If it is greater than 0, then
12292 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12293 * other than the revision date should be propagated, and bit 1 indicates
12294 * that the revision date should be propagated.
12296 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12298 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12299 * Incorporates, with permission, some code from EZCOPY by Tim Adye
12300 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12301 * as part of the Perl standard distribution under the terms of the
12302 * GNU General Public License or the Perl Artistic License. Copies
12303 * of each may be found in the Perl standard distribution.
12305 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12307 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12309 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12310 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12311 unsigned long int sts;
12313 struct FAB fab_in, fab_out;
12314 struct RAB rab_in, rab_out;
12315 rms_setup_nam(nam);
12316 rms_setup_nam(nam_out);
12317 struct XABDAT xabdat;
12318 struct XABFHC xabfhc;
12319 struct XABRDT xabrdt;
12320 struct XABSUM xabsum;
12322 vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12323 if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12324 vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12325 if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12326 if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12327 !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12328 PerlMem_free(vmsin);
12329 PerlMem_free(vmsout);
12330 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12334 esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12335 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12337 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12338 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12339 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12341 fab_in = cc$rms_fab;
12342 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12343 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12344 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12345 fab_in.fab$l_fop = FAB$M_SQO;
12346 rms_bind_fab_nam(fab_in, nam);
12347 fab_in.fab$l_xab = (void *) &xabdat;
12349 rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12350 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12352 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12353 rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12354 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12356 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12357 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12358 rms_nam_esl(nam) = 0;
12359 rms_nam_rsl(nam) = 0;
12360 rms_nam_esll(nam) = 0;
12361 rms_nam_rsll(nam) = 0;
12362 #ifdef NAM$M_NO_SHORT_UPCASE
12363 if (decc_efs_case_preserve)
12364 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12367 xabdat = cc$rms_xabdat; /* To get creation date */
12368 xabdat.xab$l_nxt = (void *) &xabfhc;
12370 xabfhc = cc$rms_xabfhc; /* To get record length */
12371 xabfhc.xab$l_nxt = (void *) &xabsum;
12373 xabsum = cc$rms_xabsum; /* To get key and area information */
12375 if (!((sts = sys$open(&fab_in)) & 1)) {
12376 PerlMem_free(vmsin);
12377 PerlMem_free(vmsout);
12380 PerlMem_free(esal);
12383 PerlMem_free(rsal);
12384 set_vaxc_errno(sts);
12386 case RMS$_FNF: case RMS$_DNF:
12387 set_errno(ENOENT); break;
12389 set_errno(ENOTDIR); break;
12391 set_errno(ENODEV); break;
12393 set_errno(EINVAL); break;
12395 set_errno(EACCES); break;
12397 set_errno(EVMSERR);
12404 fab_out.fab$w_ifi = 0;
12405 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12406 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12407 fab_out.fab$l_fop = FAB$M_SQO;
12408 rms_bind_fab_nam(fab_out, nam_out);
12409 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12410 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12411 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12412 esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12413 if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12414 rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12415 if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12418 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12419 esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12420 if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12421 rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12422 if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12424 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12425 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12427 if (preserve_dates == 0) { /* Act like DCL COPY */
12428 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12429 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
12430 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12431 PerlMem_free(vmsin);
12432 PerlMem_free(vmsout);
12435 PerlMem_free(esal);
12438 PerlMem_free(rsal);
12439 PerlMem_free(esa_out);
12440 if (esal_out != NULL)
12441 PerlMem_free(esal_out);
12442 PerlMem_free(rsa_out);
12443 if (rsal_out != NULL)
12444 PerlMem_free(rsal_out);
12445 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12446 set_vaxc_errno(sts);
12449 fab_out.fab$l_xab = (void *) &xabdat;
12450 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12451 preserve_dates = 1;
12453 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12454 preserve_dates =0; /* bitmask from this point forward */
12456 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12457 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12458 PerlMem_free(vmsin);
12459 PerlMem_free(vmsout);
12462 PerlMem_free(esal);
12465 PerlMem_free(rsal);
12466 PerlMem_free(esa_out);
12467 if (esal_out != NULL)
12468 PerlMem_free(esal_out);
12469 PerlMem_free(rsa_out);
12470 if (rsal_out != NULL)
12471 PerlMem_free(rsal_out);
12472 set_vaxc_errno(sts);
12475 set_errno(ENOENT); break;
12477 set_errno(ENOTDIR); break;
12479 set_errno(ENODEV); break;
12481 set_errno(EINVAL); break;
12483 set_errno(EACCES); break;
12485 set_errno(EVMSERR);
12489 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12490 if (preserve_dates & 2) {
12491 /* sys$close() will process xabrdt, not xabdat */
12492 xabrdt = cc$rms_xabrdt;
12494 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12496 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12497 * is unsigned long[2], while DECC & VAXC use a struct */
12498 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12500 fab_out.fab$l_xab = (void *) &xabrdt;
12503 ubf = (char *)PerlMem_malloc(32256);
12504 if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12505 rab_in = cc$rms_rab;
12506 rab_in.rab$l_fab = &fab_in;
12507 rab_in.rab$l_rop = RAB$M_BIO;
12508 rab_in.rab$l_ubf = ubf;
12509 rab_in.rab$w_usz = 32256;
12510 if (!((sts = sys$connect(&rab_in)) & 1)) {
12511 sys$close(&fab_in); sys$close(&fab_out);
12512 PerlMem_free(vmsin);
12513 PerlMem_free(vmsout);
12517 PerlMem_free(esal);
12520 PerlMem_free(rsal);
12521 PerlMem_free(esa_out);
12522 if (esal_out != NULL)
12523 PerlMem_free(esal_out);
12524 PerlMem_free(rsa_out);
12525 if (rsal_out != NULL)
12526 PerlMem_free(rsal_out);
12527 set_errno(EVMSERR); set_vaxc_errno(sts);
12531 rab_out = cc$rms_rab;
12532 rab_out.rab$l_fab = &fab_out;
12533 rab_out.rab$l_rbf = ubf;
12534 if (!((sts = sys$connect(&rab_out)) & 1)) {
12535 sys$close(&fab_in); sys$close(&fab_out);
12536 PerlMem_free(vmsin);
12537 PerlMem_free(vmsout);
12541 PerlMem_free(esal);
12544 PerlMem_free(rsal);
12545 PerlMem_free(esa_out);
12546 if (esal_out != NULL)
12547 PerlMem_free(esal_out);
12548 PerlMem_free(rsa_out);
12549 if (rsal_out != NULL)
12550 PerlMem_free(rsal_out);
12551 set_errno(EVMSERR); set_vaxc_errno(sts);
12555 while ((sts = sys$read(&rab_in))) { /* always true */
12556 if (sts == RMS$_EOF) break;
12557 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12558 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12559 sys$close(&fab_in); sys$close(&fab_out);
12560 PerlMem_free(vmsin);
12561 PerlMem_free(vmsout);
12565 PerlMem_free(esal);
12568 PerlMem_free(rsal);
12569 PerlMem_free(esa_out);
12570 if (esal_out != NULL)
12571 PerlMem_free(esal_out);
12572 PerlMem_free(rsa_out);
12573 if (rsal_out != NULL)
12574 PerlMem_free(rsal_out);
12575 set_errno(EVMSERR); set_vaxc_errno(sts);
12581 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12582 sys$close(&fab_in); sys$close(&fab_out);
12583 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12585 PerlMem_free(vmsin);
12586 PerlMem_free(vmsout);
12590 PerlMem_free(esal);
12593 PerlMem_free(rsal);
12594 PerlMem_free(esa_out);
12595 if (esal_out != NULL)
12596 PerlMem_free(esal_out);
12597 PerlMem_free(rsa_out);
12598 if (rsal_out != NULL)
12599 PerlMem_free(rsal_out);
12602 set_errno(EVMSERR); set_vaxc_errno(sts);
12608 } /* end of rmscopy() */
12612 /*** The following glue provides 'hooks' to make some of the routines
12613 * from this file available from Perl. These routines are sufficiently
12614 * basic, and are required sufficiently early in the build process,
12615 * that's it's nice to have them available to miniperl as well as the
12616 * full Perl, so they're set up here instead of in an extension. The
12617 * Perl code which handles importation of these names into a given
12618 * package lives in [.VMS]Filespec.pm in @INC.
12622 rmsexpand_fromperl(pTHX_ CV *cv)
12625 char *fspec, *defspec = NULL, *rslt;
12627 int fs_utf8, dfs_utf8;
12631 if (!items || items > 2)
12632 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12633 fspec = SvPV(ST(0),n_a);
12634 fs_utf8 = SvUTF8(ST(0));
12635 if (!fspec || !*fspec) XSRETURN_UNDEF;
12637 defspec = SvPV(ST(1),n_a);
12638 dfs_utf8 = SvUTF8(ST(1));
12640 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12641 ST(0) = sv_newmortal();
12642 if (rslt != NULL) {
12643 sv_usepvn(ST(0),rslt,strlen(rslt));
12652 vmsify_fromperl(pTHX_ CV *cv)
12659 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12660 utf8_fl = SvUTF8(ST(0));
12661 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12662 ST(0) = sv_newmortal();
12663 if (vmsified != NULL) {
12664 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12673 unixify_fromperl(pTHX_ CV *cv)
12680 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12681 utf8_fl = SvUTF8(ST(0));
12682 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12683 ST(0) = sv_newmortal();
12684 if (unixified != NULL) {
12685 sv_usepvn(ST(0),unixified,strlen(unixified));
12694 fileify_fromperl(pTHX_ CV *cv)
12701 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12702 utf8_fl = SvUTF8(ST(0));
12703 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12704 ST(0) = sv_newmortal();
12705 if (fileified != NULL) {
12706 sv_usepvn(ST(0),fileified,strlen(fileified));
12715 pathify_fromperl(pTHX_ CV *cv)
12722 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12723 utf8_fl = SvUTF8(ST(0));
12724 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12725 ST(0) = sv_newmortal();
12726 if (pathified != NULL) {
12727 sv_usepvn(ST(0),pathified,strlen(pathified));
12736 vmspath_fromperl(pTHX_ CV *cv)
12743 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12744 utf8_fl = SvUTF8(ST(0));
12745 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12746 ST(0) = sv_newmortal();
12747 if (vmspath != NULL) {
12748 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12757 unixpath_fromperl(pTHX_ CV *cv)
12764 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12765 utf8_fl = SvUTF8(ST(0));
12766 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12767 ST(0) = sv_newmortal();
12768 if (unixpath != NULL) {
12769 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12778 candelete_fromperl(pTHX_ CV *cv)
12786 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12788 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12789 Newx(fspec, VMS_MAXRSS, char);
12790 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12791 if (isGV_with_GP(mysv)) {
12792 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12793 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12801 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12802 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12809 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12815 rmscopy_fromperl(pTHX_ CV *cv)
12818 char *inspec, *outspec, *inp, *outp;
12824 if (items < 2 || items > 3)
12825 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12827 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12828 Newx(inspec, VMS_MAXRSS, char);
12829 if (isGV_with_GP(mysv)) {
12830 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12831 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12832 ST(0) = sv_2mortal(newSViv(0));
12839 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12840 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12841 ST(0) = sv_2mortal(newSViv(0));
12846 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12847 Newx(outspec, VMS_MAXRSS, char);
12848 if (isGV_with_GP(mysv)) {
12849 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12850 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12851 ST(0) = sv_2mortal(newSViv(0));
12859 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12860 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12861 ST(0) = sv_2mortal(newSViv(0));
12867 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12869 ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12875 /* The mod2fname is limited to shorter filenames by design, so it should
12876 * not be modified to support longer EFS pathnames
12879 mod2fname(pTHX_ CV *cv)
12882 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12883 workbuff[NAM$C_MAXRSS*1 + 1];
12884 int counter, num_entries;
12885 /* ODS-5 ups this, but we want to be consistent, so... */
12886 int max_name_len = 39;
12887 AV *in_array = (AV *)SvRV(ST(0));
12889 num_entries = av_len(in_array);
12891 /* All the names start with PL_. */
12892 strcpy(ultimate_name, "PL_");
12894 /* Clean up our working buffer */
12895 Zero(work_name, sizeof(work_name), char);
12897 /* Run through the entries and build up a working name */
12898 for(counter = 0; counter <= num_entries; counter++) {
12899 /* If it's not the first name then tack on a __ */
12901 my_strlcat(work_name, "__", sizeof(work_name));
12903 my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12906 /* Check to see if we actually have to bother...*/
12907 if (strlen(work_name) + 3 <= max_name_len) {
12908 my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12910 /* It's too darned big, so we need to go strip. We use the same */
12911 /* algorithm as xsubpp does. First, strip out doubled __ */
12912 char *source, *dest, last;
12915 for (source = work_name; *source; source++) {
12916 if (last == *source && last == '_') {
12922 /* Go put it back */
12923 my_strlcpy(work_name, workbuff, sizeof(work_name));
12924 /* Is it still too big? */
12925 if (strlen(work_name) + 3 > max_name_len) {
12926 /* Strip duplicate letters */
12929 for (source = work_name; *source; source++) {
12930 if (last == toupper(*source)) {
12934 last = toupper(*source);
12936 my_strlcpy(work_name, workbuff, sizeof(work_name));
12939 /* Is it *still* too big? */
12940 if (strlen(work_name) + 3 > max_name_len) {
12941 /* Too bad, we truncate */
12942 work_name[max_name_len - 2] = 0;
12944 my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12947 /* Okay, return it */
12948 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12953 hushexit_fromperl(pTHX_ CV *cv)
12958 VMSISH_HUSHED = SvTRUE(ST(0));
12960 ST(0) = boolSV(VMSISH_HUSHED);
12966 Perl_vms_start_glob
12967 (pTHX_ SV *tmpglob,
12971 struct vs_str_st *rslt;
12975 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12978 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12979 struct dsc$descriptor_vs rsdsc;
12980 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12981 unsigned long hasver = 0, isunix = 0;
12982 unsigned long int lff_flags = 0;
12984 int vms_old_glob = 1;
12986 if (!SvOK(tmpglob)) {
12987 SETERRNO(ENOENT,RMS$_FNF);
12991 vms_old_glob = !decc_filename_unix_report;
12993 #ifdef VMS_LONGNAME_SUPPORT
12994 lff_flags = LIB$M_FIL_LONG_NAMES;
12996 /* The Newx macro will not allow me to assign a smaller array
12997 * to the rslt pointer, so we will assign it to the begin char pointer
12998 * and then copy the value into the rslt pointer.
13000 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13001 rslt = (struct vs_str_st *)begin;
13003 rstr = &rslt->str[0];
13004 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13005 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13006 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13007 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13009 Newx(vmsspec, VMS_MAXRSS, char);
13011 /* We could find out if there's an explicit dev/dir or version
13012 by peeking into lib$find_file's internal context at
13013 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13014 but that's unsupported, so I don't want to do it now and
13015 have it bite someone in the future. */
13016 /* Fix-me: vms_split_path() is the only way to do this, the
13017 existing method will fail with many legal EFS or UNIX specifications
13020 cp = SvPV(tmpglob,i);
13023 if (cp[i] == ';') hasver = 1;
13024 if (cp[i] == '.') {
13025 if (sts) hasver = 1;
13028 if (cp[i] == '/') {
13029 hasdir = isunix = 1;
13032 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13038 /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13039 if ((hasdir == 0) && decc_filename_unix_report) {
13043 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13044 char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13045 int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13051 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13052 if (!stat_sts && S_ISDIR(st.st_mode)) {
13054 const char * fname;
13057 /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13058 /* path delimiter of ':>]', if so, then the old behavior has */
13059 /* obviously been specifically requested */
13061 fname = SvPVX_const(tmpglob);
13062 fname_len = strlen(fname);
13063 vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13064 if (vms_old_glob || (vms_dir != NULL)) {
13065 wilddsc.dsc$a_pointer = tovmspath_utf8(
13066 SvPVX(tmpglob),vmsspec,NULL);
13067 ok = (wilddsc.dsc$a_pointer != NULL);
13068 /* maybe passed 'foo' rather than '[.foo]', thus not
13072 /* Operate just on the directory, the special stat/fstat for */
13073 /* leaves the fileified specification in the st_devnam */
13075 wilddsc.dsc$a_pointer = st.st_devnam;
13080 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13081 ok = (wilddsc.dsc$a_pointer != NULL);
13084 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13086 /* If not extended character set, replace ? with % */
13087 /* With extended character set, ? is a wildcard single character */
13088 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13091 if (!decc_efs_charset)
13093 } else if (*cp == '%') {
13095 } else if (*cp == '*') {
13101 wv_sts = vms_split_path(
13102 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13103 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13104 &wvs_spec, &wvs_len);
13113 while (ok && $VMS_STATUS_SUCCESS(sts)) {
13114 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13115 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13119 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13120 &dfltdsc,NULL,&rms_sts,&lff_flags);
13121 if (!$VMS_STATUS_SUCCESS(sts))
13124 /* with varying string, 1st word of buffer contains result length */
13125 rstr[rslt->length] = '\0';
13127 /* Find where all the components are */
13128 v_sts = vms_split_path
13143 /* If no version on input, truncate the version on output */
13144 if (!hasver && (vs_len > 0)) {
13151 /* In Unix report mode, remove the ".dir;1" from the name */
13152 /* if it is a real directory */
13153 if (decc_filename_unix_report || decc_efs_charset) {
13154 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13158 ret_sts = flex_lstat(rstr, &statbuf);
13159 if ((ret_sts == 0) &&
13160 S_ISDIR(statbuf.st_mode)) {
13167 /* No version & a null extension on UNIX handling */
13168 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13174 if (!decc_efs_case_preserve) {
13175 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13178 /* Find File treats a Null extension as return all extensions */
13179 /* This is contrary to Perl expectations */
13181 if (wildstar || wildquery || vms_old_glob) {
13182 /* really need to see if the returned file name matched */
13183 /* but for now will assume that it matches */
13186 /* Exact Match requested */
13187 /* How are directories handled? - like a file */
13188 if ((e_len == we_len) && (n_len == wn_len)) {
13192 t1 = strncmp(e_spec, we_spec, e_len);
13196 t1 = strncmp(n_spec, we_spec, n_len);
13207 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13211 /* Start with the name */
13214 strcat(begin,"\n");
13215 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13218 if (cxt) (void)lib$find_file_end(&cxt);
13221 /* Be POSIXish: return the input pattern when no matches */
13222 my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13224 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13227 if (ok && sts != RMS$_NMF &&
13228 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13231 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13233 PerlIO_close(tmpfp);
13237 PerlIO_rewind(tmpfp);
13238 IoTYPE(io) = IoTYPE_RDONLY;
13239 IoIFP(io) = fp = tmpfp;
13240 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
13250 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13254 unixrealpath_fromperl(pTHX_ CV *cv)
13257 char *fspec, *rslt_spec, *rslt;
13260 if (!items || items != 1)
13261 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13263 fspec = SvPV(ST(0),n_a);
13264 if (!fspec || !*fspec) XSRETURN_UNDEF;
13266 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13267 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13269 ST(0) = sv_newmortal();
13271 sv_usepvn(ST(0),rslt,strlen(rslt));
13273 Safefree(rslt_spec);
13278 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13282 vmsrealpath_fromperl(pTHX_ CV *cv)
13285 char *fspec, *rslt_spec, *rslt;
13288 if (!items || items != 1)
13289 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13291 fspec = SvPV(ST(0),n_a);
13292 if (!fspec || !*fspec) XSRETURN_UNDEF;
13294 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13295 rslt = do_vms_realname(fspec, rslt_spec, NULL);
13297 ST(0) = sv_newmortal();
13299 sv_usepvn(ST(0),rslt,strlen(rslt));
13301 Safefree(rslt_spec);
13307 * A thin wrapper around decc$symlink to make sure we follow the
13308 * standard and do not create a symlink with a zero-length name,
13309 * and convert the target to Unix format, as the CRTL can't handle
13310 * targets in VMS format.
13312 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13314 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13319 if (!link_name || !*link_name) {
13320 SETERRNO(ENOENT, SS$_NOSUCHFILE);
13324 utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13325 /* An untranslatable filename should be passed through. */
13326 (void) int_tounixspec(contents, utarget, NULL);
13327 sts = symlink(utarget, link_name);
13328 PerlMem_free(utarget);
13333 #endif /* HAS_SYMLINK */
13335 int do_vms_case_tolerant(void);
13338 case_tolerant_process_fromperl(pTHX_ CV *cv)
13341 ST(0) = boolSV(do_vms_case_tolerant());
13345 #ifdef USE_ITHREADS
13348 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13349 struct interp_intern *dst)
13351 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13353 memcpy(dst,src,sizeof(struct interp_intern));
13359 Perl_sys_intern_clear(pTHX)
13364 Perl_sys_intern_init(pTHX)
13366 unsigned int ix = RAND_MAX;
13371 MY_POSIX_EXIT = vms_posix_exit;
13374 MY_INV_RAND_MAX = 1./x;
13378 init_os_extras(void)
13381 char* file = __FILE__;
13382 if (decc_disable_to_vms_logname_translation) {
13383 no_translate_barewords = TRUE;
13385 no_translate_barewords = FALSE;
13388 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13389 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13390 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13391 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13392 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13393 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13394 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13395 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13396 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13397 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13398 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13399 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13400 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13401 newXSproto("VMS::Filespec::case_tolerant_process",
13402 case_tolerant_process_fromperl,file,"");
13404 store_pipelocs(aTHX); /* will redo any earlier attempts */
13409 #if __CRTL_VER == 80200000
13410 /* This missed getting in to the DECC SDK for 8.2 */
13411 char *realpath(const char *file_name, char * resolved_name, ...);
13414 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13415 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13416 * The perl fallback routine to provide realpath() is not as efficient
13424 /* Hack, use old stat() as fastest way of getting ino_t and device */
13425 int decc$stat(const char *name, void * statbuf);
13426 #if !defined(__VAX) && __CRTL_VER >= 80200000
13427 int decc$lstat(const char *name, void * statbuf);
13429 #define decc$lstat decc$stat
13437 /* Realpath is fragile. In 8.3 it does not work if the feature
13438 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13439 * links are implemented in RMS, not the CRTL. It also can fail if the
13440 * user does not have read/execute access to some of the directories.
13441 * So in order for Do What I Mean mode to work, if realpath() fails,
13442 * fall back to looking up the filename by the device name and FID.
13445 int vms_fid_to_name(char * outname, int outlen,
13446 const char * name, int lstat_flag, mode_t * mode)
13448 #pragma message save
13449 #pragma message disable MISALGNDSTRCT
13450 #pragma message disable MISALGNDMEM
13451 #pragma member_alignment save
13452 #pragma nomember_alignment
13455 unsigned short st_ino[3];
13456 unsigned short old_st_mode;
13457 unsigned long padl[30]; /* plenty of room */
13459 #pragma message restore
13460 #pragma member_alignment restore
13463 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13464 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13469 /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13470 * unexpected answers
13473 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13474 if (fileified == NULL)
13475 _ckvmssts_noperl(SS$_INSFMEM);
13477 temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13478 if (temp_fspec == NULL)
13479 _ckvmssts_noperl(SS$_INSFMEM);
13482 /* First need to try as a directory */
13483 ret_spec = int_tovmspath(name, temp_fspec, NULL);
13484 if (ret_spec != NULL) {
13485 ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13486 if (ret_spec != NULL) {
13487 if (lstat_flag == 0)
13488 sts = decc$stat(fileified, &statbuf);
13490 sts = decc$lstat(fileified, &statbuf);
13494 /* Then as a VMS file spec */
13496 ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13497 if (ret_spec != NULL) {
13498 if (lstat_flag == 0) {
13499 sts = decc$stat(temp_fspec, &statbuf);
13501 sts = decc$lstat(temp_fspec, &statbuf);
13507 /* Next try - allow multiple dots with out EFS CHARSET */
13508 /* The CRTL stat() falls down hard on multi-dot filenames in unix
13509 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13510 * enable it if it isn't already.
13512 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13513 if (!decc_efs_charset && (decc_efs_charset_index > 0))
13514 decc$feature_set_value(decc_efs_charset_index, 1, 1);
13516 ret_spec = int_tovmspath(name, temp_fspec, NULL);
13517 if (lstat_flag == 0) {
13518 sts = decc$stat(name, &statbuf);
13520 sts = decc$lstat(name, &statbuf);
13522 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13523 if (!decc_efs_charset && (decc_efs_charset_index > 0))
13524 decc$feature_set_value(decc_efs_charset_index, 1, 0);
13529 /* and then because the Perl Unix to VMS conversion is not perfect */
13530 /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13531 /* characters from filenames so we need to try it as-is */
13533 if (lstat_flag == 0) {
13534 sts = decc$stat(name, &statbuf);
13536 sts = decc$lstat(name, &statbuf);
13543 dvidsc.dsc$a_pointer=statbuf.st_dev;
13544 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13546 specdsc.dsc$a_pointer = outname;
13547 specdsc.dsc$w_length = outlen-1;
13549 vms_sts = lib$fid_to_name
13550 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13551 if ($VMS_STATUS_SUCCESS(vms_sts)) {
13552 outname[specdsc.dsc$w_length] = 0;
13554 /* Return the mode */
13556 *mode = statbuf.old_st_mode;
13560 PerlMem_free(temp_fspec);
13561 PerlMem_free(fileified);
13568 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13571 char * rslt = NULL;
13574 if (decc_posix_compliant_pathnames > 0 ) {
13575 /* realpath currently only works if posix compliant pathnames are
13576 * enabled. It may start working when they are not, but in that
13577 * case we still want the fallback behavior for backwards compatibility
13579 rslt = realpath(filespec, outbuf);
13583 if (rslt == NULL) {
13585 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13586 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13589 /* Fall back to fid_to_name */
13591 Newx(vms_spec, VMS_MAXRSS + 1, char);
13593 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13597 /* Now need to trim the version off */
13598 sts = vms_split_path
13618 /* Trim off the version */
13619 int file_len = v_len + r_len + d_len + n_len + e_len;
13620 vms_spec[file_len] = 0;
13622 /* Trim off the .DIR if this is a directory */
13623 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13624 if (S_ISDIR(my_mode)) {
13630 /* Drop NULL extensions on UNIX file specification */
13631 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13636 /* The result is expected to be in UNIX format */
13637 rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13639 /* Downcase if input had any lower case letters and
13640 * case preservation is not in effect.
13642 if (!decc_efs_case_preserve) {
13643 for (cp = filespec; *cp; cp++)
13644 if (islower(*cp)) { haslower = 1; break; }
13646 if (haslower) __mystrtolower(rslt);
13651 /* Now for some hacks to deal with backwards and forward */
13652 /* compatibility */
13653 if (!decc_efs_charset) {
13655 /* 1. ODS-2 mode wants to do a syntax only translation */
13656 rslt = int_rmsexpand(filespec, outbuf,
13657 NULL, 0, NULL, utf8_fl);
13660 if (decc_filename_unix_report) {
13662 char * vms_dir_name;
13665 /* 2. ODS-5 / UNIX report mode should return a failure */
13666 /* if the parent directory also does not exist */
13667 /* Otherwise, get the real path for the parent */
13668 /* and add the child to it. */
13670 /* basename / dirname only available for VMS 7.0+ */
13671 /* So we may need to implement them as common routines */
13673 Newx(dir_name, VMS_MAXRSS + 1, char);
13674 Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13675 dir_name[0] = '\0';
13678 /* First try a VMS parse */
13679 sts = vms_split_path
13697 int dir_len = v_len + r_len + d_len + n_len;
13699 memcpy(dir_name, filespec, dir_len);
13700 dir_name[dir_len] = '\0';
13701 file_name = (char *)&filespec[dir_len + 1];
13704 /* This must be UNIX */
13707 tchar = strrchr(filespec, '/');
13709 if (tchar != NULL) {
13710 int dir_len = tchar - filespec;
13711 memcpy(dir_name, filespec, dir_len);
13712 dir_name[dir_len] = '\0';
13713 file_name = (char *) &filespec[dir_len + 1];
13717 /* Dir name is defaulted */
13718 if (dir_name[0] == 0) {
13720 dir_name[1] = '\0';
13723 /* Need realpath for the directory */
13724 sts = vms_fid_to_name(vms_dir_name,
13726 dir_name, 0, NULL);
13729 /* Now need to pathify it. */
13730 char *tdir = int_pathify_dirspec(vms_dir_name,
13733 /* And now add the original filespec to it */
13734 if (file_name != NULL) {
13735 my_strlcat(outbuf, file_name, VMS_MAXRSS);
13739 Safefree(vms_dir_name);
13740 Safefree(dir_name);
13744 Safefree(vms_spec);
13750 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13753 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13754 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13756 /* Fall back to fid_to_name */
13758 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13765 /* Now need to trim the version off */
13766 sts = vms_split_path
13786 /* Trim off the version */
13787 int file_len = v_len + r_len + d_len + n_len + e_len;
13788 outbuf[file_len] = 0;
13790 /* Downcase if input had any lower case letters and
13791 * case preservation is not in effect.
13793 if (!decc_efs_case_preserve) {
13794 for (cp = filespec; *cp; cp++)
13795 if (islower(*cp)) { haslower = 1; break; }
13797 if (haslower) __mystrtolower(outbuf);
13806 /* External entry points */
13807 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13808 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13810 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13811 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13813 /* case_tolerant */
13815 /*{{{int do_vms_case_tolerant(void)*/
13816 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13817 * controlled by a process setting.
13819 int do_vms_case_tolerant(void)
13821 return vms_process_case_tolerant;
13824 /* External entry points */
13825 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13826 int Perl_vms_case_tolerant(void)
13827 { return do_vms_case_tolerant(); }
13829 int Perl_vms_case_tolerant(void)
13830 { return vms_process_case_tolerant; }
13834 /* Start of DECC RTL Feature handling */
13837 /* C RTL Feature settings */
13839 #if defined(__DECC) || defined(__DECCXX)
13846 vmsperl_set_features(void)
13851 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13852 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13853 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13854 unsigned long case_perm;
13855 unsigned long case_image;
13858 /* Allow an exception to bring Perl into the VMS debugger */
13859 vms_debug_on_exception = 0;
13860 status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13861 if ($VMS_STATUS_SUCCESS(status)) {
13862 val_str[0] = _toupper(val_str[0]);
13863 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13864 vms_debug_on_exception = 1;
13866 vms_debug_on_exception = 0;
13869 /* Debug unix/vms file translation routines */
13870 vms_debug_fileify = 0;
13871 status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13872 if ($VMS_STATUS_SUCCESS(status)) {
13873 val_str[0] = _toupper(val_str[0]);
13874 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13875 vms_debug_fileify = 1;
13877 vms_debug_fileify = 0;
13881 /* Historically PERL has been doing vmsify / stat differently than */
13882 /* the CRTL. In particular, under some conditions the CRTL will */
13883 /* remove some illegal characters like spaces from filenames */
13884 /* resulting in some differences. The stat()/lstat() wrapper has */
13885 /* been reporting such file names as invalid and fails to stat them */
13886 /* fixing this bug so that stat()/lstat() accept these like the */
13887 /* CRTL does will result in several tests failing. */
13888 /* This should really be fixed, but for now, set up a feature to */
13889 /* enable it so that the impact can be studied. */
13890 vms_bug_stat_filename = 0;
13891 status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13892 if ($VMS_STATUS_SUCCESS(status)) {
13893 val_str[0] = _toupper(val_str[0]);
13894 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13895 vms_bug_stat_filename = 1;
13897 vms_bug_stat_filename = 0;
13901 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13902 vms_vtf7_filenames = 0;
13903 status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13904 if ($VMS_STATUS_SUCCESS(status)) {
13905 val_str[0] = _toupper(val_str[0]);
13906 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13907 vms_vtf7_filenames = 1;
13909 vms_vtf7_filenames = 0;
13912 /* unlink all versions on unlink() or rename() */
13913 vms_unlink_all_versions = 0;
13914 status = simple_trnlnm
13915 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13916 if ($VMS_STATUS_SUCCESS(status)) {
13917 val_str[0] = _toupper(val_str[0]);
13918 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13919 vms_unlink_all_versions = 1;
13921 vms_unlink_all_versions = 0;
13924 /* Dectect running under GNV Bash or other UNIX like shell */
13925 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13926 gnv_unix_shell = 0;
13927 status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13928 if ($VMS_STATUS_SUCCESS(status)) {
13929 gnv_unix_shell = 1;
13930 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13931 set_feature_default("DECC$EFS_CHARSET", 1);
13932 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13933 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13934 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13935 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13936 vms_unlink_all_versions = 1;
13937 vms_posix_exit = 1;
13941 /* hacks to see if known bugs are still present for testing */
13943 /* PCP mode requires creating /dev/null special device file */
13944 decc_bug_devnull = 0;
13945 status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13946 if ($VMS_STATUS_SUCCESS(status)) {
13947 val_str[0] = _toupper(val_str[0]);
13948 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13949 decc_bug_devnull = 1;
13951 decc_bug_devnull = 0;
13954 /* UNIX directory names with no paths are broken in a lot of places */
13955 decc_dir_barename = 1;
13956 status = simple_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13957 if ($VMS_STATUS_SUCCESS(status)) {
13958 val_str[0] = _toupper(val_str[0]);
13959 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13960 decc_dir_barename = 1;
13962 decc_dir_barename = 0;
13965 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13966 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13968 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13969 if (decc_disable_to_vms_logname_translation < 0)
13970 decc_disable_to_vms_logname_translation = 0;
13973 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13975 decc_efs_case_preserve = decc$feature_get_value(s, 1);
13976 if (decc_efs_case_preserve < 0)
13977 decc_efs_case_preserve = 0;
13980 s = decc$feature_get_index("DECC$EFS_CHARSET");
13981 decc_efs_charset_index = s;
13983 decc_efs_charset = decc$feature_get_value(s, 1);
13984 if (decc_efs_charset < 0)
13985 decc_efs_charset = 0;
13988 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13990 decc_filename_unix_report = decc$feature_get_value(s, 1);
13991 if (decc_filename_unix_report > 0) {
13992 decc_filename_unix_report = 1;
13993 vms_posix_exit = 1;
13996 decc_filename_unix_report = 0;
13999 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14001 decc_filename_unix_only = decc$feature_get_value(s, 1);
14002 if (decc_filename_unix_only > 0) {
14003 decc_filename_unix_only = 1;
14006 decc_filename_unix_only = 0;
14010 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14012 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14013 if (decc_filename_unix_no_version < 0)
14014 decc_filename_unix_no_version = 0;
14017 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14019 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14020 if (decc_readdir_dropdotnotype < 0)
14021 decc_readdir_dropdotnotype = 0;
14024 #if __CRTL_VER >= 80200000
14025 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14027 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14028 if (decc_posix_compliant_pathnames < 0)
14029 decc_posix_compliant_pathnames = 0;
14030 if (decc_posix_compliant_pathnames > 4)
14031 decc_posix_compliant_pathnames = 0;
14036 status = simple_trnlnm
14037 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14038 if ($VMS_STATUS_SUCCESS(status)) {
14039 val_str[0] = _toupper(val_str[0]);
14040 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14041 decc_disable_to_vms_logname_translation = 1;
14046 status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14047 if ($VMS_STATUS_SUCCESS(status)) {
14048 val_str[0] = _toupper(val_str[0]);
14049 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14050 decc_efs_case_preserve = 1;
14055 status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14056 if ($VMS_STATUS_SUCCESS(status)) {
14057 val_str[0] = _toupper(val_str[0]);
14058 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14059 decc_filename_unix_report = 1;
14062 status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14063 if ($VMS_STATUS_SUCCESS(status)) {
14064 val_str[0] = _toupper(val_str[0]);
14065 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14066 decc_filename_unix_only = 1;
14067 decc_filename_unix_report = 1;
14070 status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14071 if ($VMS_STATUS_SUCCESS(status)) {
14072 val_str[0] = _toupper(val_str[0]);
14073 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14074 decc_filename_unix_no_version = 1;
14077 status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14078 if ($VMS_STATUS_SUCCESS(status)) {
14079 val_str[0] = _toupper(val_str[0]);
14080 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14081 decc_readdir_dropdotnotype = 1;
14086 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14088 /* Report true case tolerance */
14089 /*----------------------------*/
14090 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14091 if (!$VMS_STATUS_SUCCESS(status))
14092 case_perm = PPROP$K_CASE_BLIND;
14093 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14094 if (!$VMS_STATUS_SUCCESS(status))
14095 case_image = PPROP$K_CASE_BLIND;
14096 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14097 (case_image == PPROP$K_CASE_SENSITIVE))
14098 vms_process_case_tolerant = 0;
14102 /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
14103 /* for strict backward compatibility */
14104 status = simple_trnlnm
14105 ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14106 if ($VMS_STATUS_SUCCESS(status)) {
14107 val_str[0] = _toupper(val_str[0]);
14108 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14109 vms_posix_exit = 1;
14111 vms_posix_exit = 0;
14115 /* Use 32-bit pointers because that's what the image activator
14116 * assumes for the LIB$INITIALZE psect.
14118 #if __INITIAL_POINTER_SIZE
14119 #pragma pointer_size save
14120 #pragma pointer_size 32
14123 /* Create a reference to the LIB$INITIALIZE function. */
14124 extern void LIB$INITIALIZE(void);
14125 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14127 /* Create an array of pointers to the init functions in the special
14128 * LIB$INITIALIZE section. In our case, the array only has one entry.
14130 #pragma extern_model save
14131 #pragma extern_model strict_refdef "LIB$INITIALIZE" gbl,noexe,nowrt,noshr,long
14132 extern void (* const vmsperl_unused_global_2[])() =
14134 vmsperl_set_features,
14136 #pragma extern_model restore
14138 #if __INITIAL_POINTER_SIZE
14139 #pragma pointer_size restore
14146 #endif /* defined(__DECC) || defined(__DECCXX) */