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 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;
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 char *s, *rest, *cp, *wordbreak;
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; }
10471 /* If the first word is quoted, then we need to unquote it and
10472 * escape spaces within it. We'll expand into the resspec buffer,
10473 * then copy back into the cmd buffer, expanding the latter if
10476 if (*rest == '"') {
10481 int soff = s - cmd;
10483 for (cp2 = resspec;
10484 *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10487 if (*rest == ' ') { /* Escape ' ' to '^_'. */
10493 else if (*rest == '"') {
10495 if (in_quote) { /* Must be closing quote. */
10508 /* Expand the command buffer if necessary. */
10509 if (clen > cmdlen) {
10510 cmd = (char *)PerlMem_realloc(cmd, clen);
10512 _ckvmssts_noperl(SS$_INSFMEM);
10513 /* Where we are may have changed, so recompute offsets */
10514 r = cmd + (r - s - soff);
10515 rest = cmd + (rest - s - soff);
10519 /* Shift the non-verb portion of the command (if any) up or
10520 * down as necessary.
10523 memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10525 /* Copy the unquoted and escaped command verb into place. */
10526 memcpy(r, resspec, cp2 - resspec);
10529 rest = r; /* Rewind for subsequent operations. */
10532 if (*rest == '.' || *rest == '/') {
10534 for (cp2 = resspec;
10535 *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10536 rest++, cp2++) *cp2 = *rest;
10538 if (int_tovmsspec(resspec, cp, 0, NULL)) {
10541 /* When a UNIX spec with no file type is translated to VMS, */
10542 /* A trailing '.' is appended under ODS-5 rules. */
10543 /* Here we do not want that trailing "." as it prevents */
10544 /* Looking for a implied ".exe" type. */
10545 if (decc_efs_charset) {
10547 i = strlen(vmsspec);
10548 if (vmsspec[i-1] == '.') {
10549 vmsspec[i-1] = '\0';
10554 for (cp2 = vmsspec + strlen(vmsspec);
10555 *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10556 rest++, cp2++) *cp2 = *rest;
10561 /* Intuit whether verb (first word of cmd) is a DCL command:
10562 * - if first nonspace char is '@', it's a DCL indirection
10564 * - if verb contains a filespec separator, it's not a DCL command
10565 * - if it doesn't, caller tells us whether to default to a DCL
10566 * command, or to a local image unless told it's DCL (by leading '$')
10570 if (suggest_quote) *suggest_quote = 1;
10572 char *filespec = strpbrk(s,":<[.;");
10573 rest = wordbreak = strpbrk(s," \"\t/");
10574 if (!wordbreak) wordbreak = s + strlen(s);
10575 if (*s == '$') check_img = 0;
10576 if (filespec && (filespec < wordbreak)) isdcl = 0;
10577 else isdcl = !check_img;
10582 imgdsc.dsc$a_pointer = s;
10583 imgdsc.dsc$w_length = wordbreak - s;
10584 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10586 _ckvmssts_noperl(lib$find_file_end(&cxt));
10587 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10588 if (!(retsts & 1) && *s == '$') {
10589 _ckvmssts_noperl(lib$find_file_end(&cxt));
10590 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10591 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10593 _ckvmssts_noperl(lib$find_file_end(&cxt));
10594 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10598 _ckvmssts_noperl(lib$find_file_end(&cxt));
10603 while (*s && !isspace(*s)) s++;
10606 /* check that it's really not DCL with no file extension */
10607 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10609 char b[256] = {0,0,0,0};
10610 read(fileno(fp), b, 256);
10611 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10615 /* Check for script */
10617 if ((b[0] == '#') && (b[1] == '!'))
10619 #ifdef ALTERNATE_SHEBANG
10621 shebang_len = strlen(ALTERNATE_SHEBANG);
10622 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10624 perlstr = strstr("perl",b);
10625 if (perlstr == NULL)
10633 if (shebang_len > 0) {
10636 char tmpspec[NAM$C_MAXRSS + 1];
10639 /* Image is following after white space */
10640 /*--------------------------------------*/
10641 while (isprint(b[i]) && isspace(b[i]))
10645 while (isprint(b[i]) && !isspace(b[i])) {
10646 tmpspec[j++] = b[i++];
10647 if (j >= NAM$C_MAXRSS)
10652 /* There may be some default parameters to the image */
10653 /*---------------------------------------------------*/
10655 while (isprint(b[i])) {
10656 image_argv[j++] = b[i++];
10657 if (j >= NAM$C_MAXRSS)
10660 while ((j > 0) && !isprint(image_argv[j-1]))
10664 /* It will need to be converted to VMS format and validated */
10665 if (tmpspec[0] != '\0') {
10668 /* Try to find the exact program requested to be run */
10669 /*---------------------------------------------------*/
10670 iname = int_rmsexpand
10671 (tmpspec, image_name, ".exe",
10672 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10673 if (iname != NULL) {
10674 if (cando_by_name_int
10675 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10676 /* MCR prefix needed */
10680 /* Try again with a null type */
10681 /*----------------------------*/
10682 iname = int_rmsexpand
10683 (tmpspec, image_name, ".",
10684 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10685 if (iname != NULL) {
10686 if (cando_by_name_int
10687 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10688 /* MCR prefix needed */
10694 /* Did we find the image to run the script? */
10695 /*------------------------------------------*/
10699 /* Assume DCL or foreign command exists */
10700 /*--------------------------------------*/
10701 tchr = strrchr(tmpspec, '/');
10702 if (tchr != NULL) {
10708 my_strlcpy(image_name, tchr, sizeof(image_name));
10716 if (check_img && isdcl) {
10718 PerlMem_free(resspec);
10719 PerlMem_free(vmsspec);
10723 if (cando_by_name(S_IXUSR,0,resspec)) {
10724 vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10725 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10727 my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10728 if (image_name[0] != 0) {
10729 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10730 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10732 } else if (image_name[0] != 0) {
10733 my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10734 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10736 my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10738 if (suggest_quote) *suggest_quote = 1;
10740 /* If there is an image name, use original command */
10741 if (image_name[0] == 0)
10742 my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10745 while (*rest && isspace(*rest)) rest++;
10748 if (image_argv[0] != 0) {
10749 my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10750 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10756 rest_len = strlen(rest);
10757 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10758 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10759 my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10761 retsts = CLI$_BUFOVF;
10763 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10765 PerlMem_free(vmsspec);
10766 PerlMem_free(resspec);
10767 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10773 /* It's either a DCL command or we couldn't find a suitable image */
10774 vmscmd->dsc$w_length = strlen(cmd);
10776 vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10777 my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10780 PerlMem_free(resspec);
10781 PerlMem_free(vmsspec);
10783 /* check if it's a symbol (for quoting purposes) */
10784 if (suggest_quote && !*suggest_quote) {
10786 char equiv[LNM$C_NAMLENGTH];
10787 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10788 eqvdsc.dsc$a_pointer = equiv;
10790 iss = lib$get_symbol(vmscmd,&eqvdsc);
10791 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10793 if (!(retsts & 1)) {
10794 /* just hand off status values likely to be due to user error */
10795 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10796 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10797 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10798 else { _ckvmssts_noperl(retsts); }
10801 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10803 } /* end of setup_cmddsc() */
10806 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10808 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10814 if (vfork_called) { /* this follows a vfork - act Unixish */
10816 if (vfork_called < 0) {
10817 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10820 else return do_aexec(really,mark,sp);
10822 /* no vfork - act VMSish */
10823 cmd = setup_argstr(aTHX_ really,mark,sp);
10824 exec_sts = vms_do_exec(cmd);
10825 Safefree(cmd); /* Clean up from setup_argstr() */
10830 } /* end of vms_do_aexec() */
10833 /* {{{bool vms_do_exec(char *cmd) */
10835 Perl_vms_do_exec(pTHX_ const char *cmd)
10837 struct dsc$descriptor_s *vmscmd;
10839 if (vfork_called) { /* this follows a vfork - act Unixish */
10841 if (vfork_called < 0) {
10842 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10845 else return do_exec(cmd);
10848 { /* no vfork - act VMSish */
10849 unsigned long int retsts;
10852 TAINT_PROPER("exec");
10853 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10854 retsts = lib$do_command(vmscmd);
10857 case RMS$_FNF: case RMS$_DNF:
10858 set_errno(ENOENT); break;
10860 set_errno(ENOTDIR); break;
10862 set_errno(ENODEV); break;
10864 set_errno(EACCES); break;
10866 set_errno(EINVAL); break;
10867 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10868 set_errno(E2BIG); break;
10869 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10870 _ckvmssts_noperl(retsts); /* fall through */
10871 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10872 set_errno(EVMSERR);
10874 set_vaxc_errno(retsts);
10875 if (ckWARN(WARN_EXEC)) {
10876 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10877 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10879 vms_execfree(vmscmd);
10884 } /* end of vms_do_exec() */
10887 int do_spawn2(pTHX_ const char *, int);
10890 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10892 unsigned long int sts;
10898 /* We'll copy the (undocumented?) Win32 behavior and allow a
10899 * numeric first argument. But the only value we'll support
10900 * through do_aspawn is a value of 1, which means spawn without
10901 * waiting for completion -- other values are ignored.
10903 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10905 flags = SvIVx(*mark);
10908 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
10909 flags = CLI$M_NOWAIT;
10913 cmd = setup_argstr(aTHX_ really, mark, sp);
10914 sts = do_spawn2(aTHX_ cmd, flags);
10915 /* pp_sys will clean up cmd */
10919 } /* end of do_aspawn() */
10923 /* {{{int do_spawn(char* cmd) */
10925 Perl_do_spawn(pTHX_ char* cmd)
10927 PERL_ARGS_ASSERT_DO_SPAWN;
10929 return do_spawn2(aTHX_ cmd, 0);
10933 /* {{{int do_spawn_nowait(char* cmd) */
10935 Perl_do_spawn_nowait(pTHX_ char* cmd)
10937 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10939 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10943 /* {{{int do_spawn2(char *cmd) */
10945 do_spawn2(pTHX_ const char *cmd, int flags)
10947 unsigned long int sts, substs;
10949 /* The caller of this routine expects to Safefree(PL_Cmd) */
10950 Newx(PL_Cmd,10,char);
10953 TAINT_PROPER("spawn");
10954 if (!cmd || !*cmd) {
10955 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10958 case RMS$_FNF: case RMS$_DNF:
10959 set_errno(ENOENT); break;
10961 set_errno(ENOTDIR); break;
10963 set_errno(ENODEV); break;
10965 set_errno(EACCES); break;
10967 set_errno(EINVAL); break;
10968 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10969 set_errno(E2BIG); break;
10970 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10971 _ckvmssts_noperl(sts); /* fall through */
10972 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10973 set_errno(EVMSERR);
10975 set_vaxc_errno(sts);
10976 if (ckWARN(WARN_EXEC)) {
10977 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10986 if (flags & CLI$M_NOWAIT)
10989 strcpy(mode, "nW");
10991 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10994 /* sts will be the pid in the nowait case */
10997 } /* end of do_spawn2() */
11001 static unsigned int *sockflags, sockflagsize;
11004 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11005 * routines found in some versions of the CRTL can't deal with sockets.
11006 * We don't shim the other file open routines since a socket isn't
11007 * likely to be opened by a name.
11009 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11010 FILE *my_fdopen(int fd, const char *mode)
11012 FILE *fp = fdopen(fd, mode);
11015 unsigned int fdoff = fd / sizeof(unsigned int);
11016 Stat_t sbuf; /* native stat; we don't need flex_stat */
11017 if (!sockflagsize || fdoff > sockflagsize) {
11018 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
11019 else Newx (sockflags,fdoff+2,unsigned int);
11020 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11021 sockflagsize = fdoff + 2;
11023 if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11024 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11033 * Clear the corresponding bit when the (possibly) socket stream is closed.
11034 * There still a small hole: we miss an implicit close which might occur
11035 * via freopen(). >> Todo
11037 /*{{{ int my_fclose(FILE *fp)*/
11038 int my_fclose(FILE *fp) {
11040 unsigned int fd = fileno(fp);
11041 unsigned int fdoff = fd / sizeof(unsigned int);
11043 if (sockflagsize && fdoff < sockflagsize)
11044 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11052 * A simple fwrite replacement which outputs itmsz*nitm chars without
11053 * introducing record boundaries every itmsz chars.
11054 * We are using fputs, which depends on a terminating null. We may
11055 * well be writing binary data, so we need to accommodate not only
11056 * data with nulls sprinkled in the middle but also data with no null
11059 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11061 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11063 char *cp, *end, *cpd;
11065 unsigned int fd = fileno(dest);
11066 unsigned int fdoff = fd / sizeof(unsigned int);
11068 int bufsize = itmsz * nitm + 1;
11070 if (fdoff < sockflagsize &&
11071 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11072 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11076 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11077 memcpy( data, src, itmsz*nitm );
11078 data[itmsz*nitm] = '\0';
11080 end = data + itmsz * nitm;
11081 retval = (int) nitm; /* on success return # items written */
11084 while (cpd <= end) {
11085 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11086 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11088 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11092 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11095 } /* end of my_fwrite() */
11098 /*{{{ int my_flush(FILE *fp)*/
11100 Perl_my_flush(pTHX_ FILE *fp)
11103 if ((res = fflush(fp)) == 0 && fp) {
11104 #ifdef VMS_DO_SOCKETS
11106 if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11108 res = fsync(fileno(fp));
11111 * If the flush succeeded but set end-of-file, we need to clear
11112 * the error because our caller may check ferror(). BTW, this
11113 * probably means we just flushed an empty file.
11115 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11121 /* fgetname() is not returning the correct file specifications when
11122 * decc_filename_unix_report mode is active. So we have to have it
11123 * aways return filenames in VMS mode and convert it ourselves.
11126 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11128 Perl_my_fgetname(FILE *fp, char * buf) {
11132 retname = fgetname(fp, buf, 1);
11134 /* If we are in VMS mode, then we are done */
11135 if (!decc_filename_unix_report || (retname == NULL)) {
11139 /* Convert this to Unix format */
11140 vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11141 my_strlcpy(vms_name, retname, VMS_MAXRSS);
11142 retname = int_tounixspec(vms_name, buf, NULL);
11143 PerlMem_free(vms_name);
11150 * Here are replacements for the following Unix routines in the VMS environment:
11151 * getpwuid Get information for a particular UIC or UID
11152 * getpwnam Get information for a named user
11153 * getpwent Get information for each user in the rights database
11154 * setpwent Reset search to the start of the rights database
11155 * endpwent Finish searching for users in the rights database
11157 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11158 * (defined in pwd.h), which contains the following fields:-
11160 * char *pw_name; Username (in lower case)
11161 * char *pw_passwd; Hashed password
11162 * unsigned int pw_uid; UIC
11163 * unsigned int pw_gid; UIC group number
11164 * char *pw_unixdir; Default device/directory (VMS-style)
11165 * char *pw_gecos; Owner name
11166 * char *pw_dir; Default device/directory (Unix-style)
11167 * char *pw_shell; Default CLI name (eg. DCL)
11169 * If the specified user does not exist, getpwuid and getpwnam return NULL.
11171 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11172 * not the UIC member number (eg. what's returned by getuid()),
11173 * getpwuid() can accept either as input (if uid is specified, the caller's
11174 * UIC group is used), though it won't recognise gid=0.
11176 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11177 * information about other users in your group or in other groups, respectively.
11178 * If the required privilege is not available, then these routines fill only
11179 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11182 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11185 /* sizes of various UAF record fields */
11186 #define UAI$S_USERNAME 12
11187 #define UAI$S_IDENT 31
11188 #define UAI$S_OWNER 31
11189 #define UAI$S_DEFDEV 31
11190 #define UAI$S_DEFDIR 63
11191 #define UAI$S_DEFCLI 31
11192 #define UAI$S_PWD 8
11194 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
11195 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11196 (uic).uic$v_group != UIC$K_WILD_GROUP)
11198 static char __empty[]= "";
11199 static struct passwd __passwd_empty=
11200 {(char *) __empty, (char *) __empty, 0, 0,
11201 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11202 static int contxt= 0;
11203 static struct passwd __pwdcache;
11204 static char __pw_namecache[UAI$S_IDENT+1];
11207 * This routine does most of the work extracting the user information.
11209 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11212 unsigned char length;
11213 char pw_gecos[UAI$S_OWNER+1];
11215 static union uicdef uic;
11217 unsigned char length;
11218 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11221 unsigned char length;
11222 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11225 unsigned char length;
11226 char pw_shell[UAI$S_DEFCLI+1];
11228 static char pw_passwd[UAI$S_PWD+1];
11230 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11231 struct dsc$descriptor_s name_desc;
11232 unsigned long int sts;
11234 static struct itmlst_3 itmlst[]= {
11235 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
11236 {sizeof(uic), UAI$_UIC, &uic, &luic},
11237 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
11238 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
11239 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
11240 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
11241 {0, 0, NULL, NULL}};
11243 name_desc.dsc$w_length= strlen(name);
11244 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11245 name_desc.dsc$b_class= DSC$K_CLASS_S;
11246 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11248 /* Note that sys$getuai returns many fields as counted strings. */
11249 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11250 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11251 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11253 else { _ckvmssts(sts); }
11254 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
11256 if ((int) owner.length < lowner) lowner= (int) owner.length;
11257 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11258 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11259 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11260 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11261 owner.pw_gecos[lowner]= '\0';
11262 defdev.pw_dir[ldefdev+ldefdir]= '\0';
11263 defcli.pw_shell[ldefcli]= '\0';
11264 if (valid_uic(uic)) {
11265 pwd->pw_uid= uic.uic$l_uic;
11266 pwd->pw_gid= uic.uic$v_group;
11269 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11270 pwd->pw_passwd= pw_passwd;
11271 pwd->pw_gecos= owner.pw_gecos;
11272 pwd->pw_dir= defdev.pw_dir;
11273 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11274 pwd->pw_shell= defcli.pw_shell;
11275 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11277 ldir= strlen(pwd->pw_unixdir) - 1;
11278 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11281 my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11282 if (!decc_efs_case_preserve)
11283 __mystrtolower(pwd->pw_unixdir);
11288 * Get information for a named user.
11290 /*{{{struct passwd *getpwnam(char *name)*/
11291 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11293 struct dsc$descriptor_s name_desc;
11295 unsigned long int sts;
11297 __pwdcache = __passwd_empty;
11298 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11299 /* We still may be able to determine pw_uid and pw_gid */
11300 name_desc.dsc$w_length= strlen(name);
11301 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11302 name_desc.dsc$b_class= DSC$K_CLASS_S;
11303 name_desc.dsc$a_pointer= (char *) name;
11304 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11305 __pwdcache.pw_uid= uic.uic$l_uic;
11306 __pwdcache.pw_gid= uic.uic$v_group;
11309 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11310 set_vaxc_errno(sts);
11311 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11314 else { _ckvmssts(sts); }
11317 my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11318 __pwdcache.pw_name= __pw_namecache;
11319 return &__pwdcache;
11320 } /* end of my_getpwnam() */
11324 * Get information for a particular UIC or UID.
11325 * Called by my_getpwent with uid=-1 to list all users.
11327 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11328 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11330 const $DESCRIPTOR(name_desc,__pw_namecache);
11331 unsigned short lname;
11333 unsigned long int status;
11335 if (uid == (unsigned int) -1) {
11337 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11338 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11339 set_vaxc_errno(status);
11340 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11344 else { _ckvmssts(status); }
11345 } while (!valid_uic (uic));
11348 uic.uic$l_uic= uid;
11349 if (!uic.uic$v_group)
11350 uic.uic$v_group= PerlProc_getgid();
11351 if (valid_uic(uic))
11352 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11353 else status = SS$_IVIDENT;
11354 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11355 status == RMS$_PRV) {
11356 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11359 else { _ckvmssts(status); }
11361 __pw_namecache[lname]= '\0';
11362 __mystrtolower(__pw_namecache);
11364 __pwdcache = __passwd_empty;
11365 __pwdcache.pw_name = __pw_namecache;
11367 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11368 The identifier's value is usually the UIC, but it doesn't have to be,
11369 so if we can, we let fillpasswd update this. */
11370 __pwdcache.pw_uid = uic.uic$l_uic;
11371 __pwdcache.pw_gid = uic.uic$v_group;
11373 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11374 return &__pwdcache;
11376 } /* end of my_getpwuid() */
11380 * Get information for next user.
11382 /*{{{struct passwd *my_getpwent()*/
11383 struct passwd *Perl_my_getpwent(pTHX)
11385 return (my_getpwuid((unsigned int) -1));
11390 * Finish searching rights database for users.
11392 /*{{{void my_endpwent()*/
11393 void Perl_my_endpwent(pTHX)
11396 _ckvmssts(sys$finish_rdb(&contxt));
11402 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11403 * my_utime(), and flex_stat(), all of which operate on UTC unless
11404 * VMSISH_TIMES is true.
11406 /* method used to handle UTC conversions:
11407 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
11409 static int gmtime_emulation_type;
11410 /* number of secs to add to UTC POSIX-style time to get local time */
11411 static long int utc_offset_secs;
11413 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11414 * in vmsish.h. #undef them here so we can call the CRTL routines
11422 static time_t toutc_dst(time_t loc) {
11425 if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11426 loc -= utc_offset_secs;
11427 if (rsltmp->tm_isdst) loc -= 3600;
11430 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11431 ((gmtime_emulation_type || my_time(NULL)), \
11432 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11433 ((secs) - utc_offset_secs))))
11435 static time_t toloc_dst(time_t utc) {
11438 utc += utc_offset_secs;
11439 if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11440 if (rsltmp->tm_isdst) utc += 3600;
11443 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11444 ((gmtime_emulation_type || my_time(NULL)), \
11445 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11446 ((secs) + utc_offset_secs))))
11448 /* my_time(), my_localtime(), my_gmtime()
11449 * By default traffic in UTC time values, using CRTL gmtime() or
11450 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11451 * Note: We need to use these functions even when the CRTL has working
11452 * UTC support, since they also handle C<use vmsish qw(times);>
11454 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
11455 * Modified by Charles Bailey <bailey@newman.upenn.edu>
11458 /*{{{time_t my_time(time_t *timep)*/
11459 time_t Perl_my_time(pTHX_ time_t *timep)
11464 if (gmtime_emulation_type == 0) {
11465 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11466 /* results of calls to gmtime() and localtime() */
11467 /* for same &base */
11469 gmtime_emulation_type++;
11470 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11471 char off[LNM$C_NAMLENGTH+1];;
11473 gmtime_emulation_type++;
11474 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11475 gmtime_emulation_type++;
11476 utc_offset_secs = 0;
11477 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11479 else { utc_offset_secs = atol(off); }
11481 else { /* We've got a working gmtime() */
11482 struct tm gmt, local;
11485 tm_p = localtime(&base);
11487 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11488 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11489 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11490 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11495 # ifdef VMSISH_TIME
11496 if (VMSISH_TIME) when = _toloc(when);
11498 if (timep != NULL) *timep = when;
11501 } /* end of my_time() */
11505 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11507 Perl_my_gmtime(pTHX_ const time_t *timep)
11512 if (timep == NULL) {
11513 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11516 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11519 # ifdef VMSISH_TIME
11520 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11522 return gmtime(&when);
11523 } /* end of my_gmtime() */
11527 /*{{{struct tm *my_localtime(const time_t *timep)*/
11529 Perl_my_localtime(pTHX_ const time_t *timep)
11533 if (timep == NULL) {
11534 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11537 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11538 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11541 # ifdef VMSISH_TIME
11542 if (VMSISH_TIME) when = _toutc(when);
11544 /* CRTL localtime() wants UTC as input, does tz correction itself */
11545 return localtime(&when);
11546 } /* end of my_localtime() */
11549 /* Reset definitions for later calls */
11550 #define gmtime(t) my_gmtime(t)
11551 #define localtime(t) my_localtime(t)
11552 #define time(t) my_time(t)
11555 /* my_utime - update modification/access time of a file
11557 * VMS 7.3 and later implementation
11558 * Only the UTC translation is home-grown. The rest is handled by the
11559 * CRTL utime(), which will take into account the relevant feature
11560 * logicals and ODS-5 volume characteristics for true access times.
11562 * pre VMS 7.3 implementation:
11563 * The calling sequence is identical to POSIX utime(), but under
11564 * VMS with ODS-2, only the modification time is changed; ODS-2 does
11565 * not maintain access times. Restrictions differ from the POSIX
11566 * definition in that the time can be changed as long as the
11567 * caller has permission to execute the necessary IO$_MODIFY $QIO;
11568 * no separate checks are made to insure that the caller is the
11569 * owner of the file or has special privs enabled.
11570 * Code here is based on Joe Meadows' FILE utility.
11574 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11575 * to VMS epoch (01-JAN-1858 00:00:00.00)
11576 * in 100 ns intervals.
11578 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11580 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11581 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11583 #if __CRTL_VER >= 70300000
11584 struct utimbuf utc_utimes, *utc_utimesp;
11586 if (utimes != NULL) {
11587 utc_utimes.actime = utimes->actime;
11588 utc_utimes.modtime = utimes->modtime;
11589 # ifdef VMSISH_TIME
11590 /* If input was local; convert to UTC for sys svc */
11592 utc_utimes.actime = _toutc(utimes->actime);
11593 utc_utimes.modtime = _toutc(utimes->modtime);
11596 utc_utimesp = &utc_utimes;
11599 utc_utimesp = NULL;
11602 return utime(file, utc_utimesp);
11604 #else /* __CRTL_VER < 70300000 */
11608 long int bintime[2], len = 2, lowbit, unixtime,
11609 secscale = 10000000; /* seconds --> 100 ns intervals */
11610 unsigned long int chan, iosb[2], retsts;
11611 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11612 struct FAB myfab = cc$rms_fab;
11613 struct NAM mynam = cc$rms_nam;
11614 #if defined (__DECC) && defined (__VAX)
11615 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11616 * at least through VMS V6.1, which causes a type-conversion warning.
11618 # pragma message save
11619 # pragma message disable cvtdiftypes
11621 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11622 struct fibdef myfib;
11623 #if defined (__DECC) && defined (__VAX)
11624 /* This should be right after the declaration of myatr, but due
11625 * to a bug in VAX DEC C, this takes effect a statement early.
11627 # pragma message restore
11629 /* cast ok for read only parameter */
11630 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11631 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11632 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11634 if (file == NULL || *file == '\0') {
11635 SETERRNO(ENOENT, LIB$_INVARG);
11639 /* Convert to VMS format ensuring that it will fit in 255 characters */
11640 if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11641 SETERRNO(ENOENT, LIB$_INVARG);
11644 if (utimes != NULL) {
11645 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
11646 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11647 * Since time_t is unsigned long int, and lib$emul takes a signed long int
11648 * as input, we force the sign bit to be clear by shifting unixtime right
11649 * one bit, then multiplying by an extra factor of 2 in lib$emul().
11651 lowbit = (utimes->modtime & 1) ? secscale : 0;
11652 unixtime = (long int) utimes->modtime;
11653 # ifdef VMSISH_TIME
11654 /* If input was UTC; convert to local for sys svc */
11655 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11657 unixtime >>= 1; secscale <<= 1;
11658 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11659 if (!(retsts & 1)) {
11660 SETERRNO(EVMSERR, retsts);
11663 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11664 if (!(retsts & 1)) {
11665 SETERRNO(EVMSERR, retsts);
11670 /* Just get the current time in VMS format directly */
11671 retsts = sys$gettim(bintime);
11672 if (!(retsts & 1)) {
11673 SETERRNO(EVMSERR, retsts);
11678 myfab.fab$l_fna = vmsspec;
11679 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11680 myfab.fab$l_nam = &mynam;
11681 mynam.nam$l_esa = esa;
11682 mynam.nam$b_ess = (unsigned char) sizeof esa;
11683 mynam.nam$l_rsa = rsa;
11684 mynam.nam$b_rss = (unsigned char) sizeof rsa;
11685 if (decc_efs_case_preserve)
11686 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11688 /* Look for the file to be affected, letting RMS parse the file
11689 * specification for us as well. I have set errno using only
11690 * values documented in the utime() man page for VMS POSIX.
11692 retsts = sys$parse(&myfab,0,0);
11693 if (!(retsts & 1)) {
11694 set_vaxc_errno(retsts);
11695 if (retsts == RMS$_PRV) set_errno(EACCES);
11696 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11697 else set_errno(EVMSERR);
11700 retsts = sys$search(&myfab,0,0);
11701 if (!(retsts & 1)) {
11702 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11703 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11704 set_vaxc_errno(retsts);
11705 if (retsts == RMS$_PRV) set_errno(EACCES);
11706 else if (retsts == RMS$_FNF) set_errno(ENOENT);
11707 else set_errno(EVMSERR);
11711 devdsc.dsc$w_length = mynam.nam$b_dev;
11712 /* cast ok for read only parameter */
11713 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11715 retsts = sys$assign(&devdsc,&chan,0,0);
11716 if (!(retsts & 1)) {
11717 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11718 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11719 set_vaxc_errno(retsts);
11720 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
11721 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
11722 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
11723 else set_errno(EVMSERR);
11727 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11728 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11730 memset((void *) &myfib, 0, sizeof myfib);
11731 #if defined(__DECC) || defined(__DECCXX)
11732 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11733 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11734 /* This prevents the revision time of the file being reset to the current
11735 * time as a result of our IO$_MODIFY $QIO. */
11736 myfib.fib$l_acctl = FIB$M_NORECORD;
11738 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11739 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11740 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11742 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11743 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11744 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11745 _ckvmssts(sys$dassgn(chan));
11746 if (retsts & 1) retsts = iosb[0];
11747 if (!(retsts & 1)) {
11748 set_vaxc_errno(retsts);
11749 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11750 else set_errno(EVMSERR);
11756 #endif /* #if __CRTL_VER >= 70300000 */
11758 } /* end of my_utime() */
11762 * flex_stat, flex_lstat, flex_fstat
11763 * basic stat, but gets it right when asked to stat
11764 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11767 #ifndef _USE_STD_STAT
11768 /* encode_dev packs a VMS device name string into an integer to allow
11769 * simple comparisons. This can be used, for example, to check whether two
11770 * files are located on the same device, by comparing their encoded device
11771 * names. Even a string comparison would not do, because stat() reuses the
11772 * device name buffer for each call; so without encode_dev, it would be
11773 * necessary to save the buffer and use strcmp (this would mean a number of
11774 * changes to the standard Perl code, to say nothing of what a Perl script
11775 * would have to do.
11777 * The device lock id, if it exists, should be unique (unless perhaps compared
11778 * with lock ids transferred from other nodes). We have a lock id if the disk is
11779 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11780 * device names. Thus we use the lock id in preference, and only if that isn't
11781 * available, do we try to pack the device name into an integer (flagged by
11782 * the sign bit (LOCKID_MASK) being set).
11784 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11785 * name and its encoded form, but it seems very unlikely that we will find
11786 * two files on different disks that share the same encoded device names,
11787 * and even more remote that they will share the same file id (if the test
11788 * is to check for the same file).
11790 * A better method might be to use sys$device_scan on the first call, and to
11791 * search for the device, returning an index into the cached array.
11792 * The number returned would be more intelligible.
11793 * This is probably not worth it, and anyway would take quite a bit longer
11794 * on the first call.
11796 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
11797 static mydev_t encode_dev (pTHX_ const char *dev)
11800 unsigned long int f;
11805 if (!dev || !dev[0]) return 0;
11809 struct dsc$descriptor_s dev_desc;
11810 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11812 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11813 can try that first. */
11814 dev_desc.dsc$w_length = strlen (dev);
11815 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11816 dev_desc.dsc$b_class = DSC$K_CLASS_S;
11817 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
11818 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11819 if (!$VMS_STATUS_SUCCESS(status)) {
11821 case SS$_NOSUCHDEV:
11822 SETERRNO(ENODEV, status);
11828 if (lockid) return (lockid & ~LOCKID_MASK);
11832 /* Otherwise we try to encode the device name */
11836 for (q = dev + strlen(dev); q--; q >= dev) {
11841 else if (isalpha (toupper (*q)))
11842 c= toupper (*q) - 'A' + (char)10;
11844 continue; /* Skip '$'s */
11846 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11848 enc += f * (unsigned long int) c;
11850 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11852 } /* end of encode_dev() */
11853 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11854 device_no = encode_dev(aTHX_ devname)
11856 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11857 device_no = new_dev_no
11861 is_null_device(const char *name)
11863 if (decc_bug_devnull != 0) {
11864 if (strncmp("/dev/null", name, 9) == 0)
11867 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11868 The underscore prefix, controller letter, and unit number are
11869 independently optional; for our purposes, the colon punctuation
11870 is not. The colon can be trailed by optional directory and/or
11871 filename, but two consecutive colons indicates a nodename rather
11872 than a device. [pr] */
11873 if (*name == '_') ++name;
11874 if (tolower(*name++) != 'n') return 0;
11875 if (tolower(*name++) != 'l') return 0;
11876 if (tolower(*name) == 'a') ++name;
11877 if (*name == '0') ++name;
11878 return (*name++ == ':') && (*name != ':');
11882 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11884 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11887 Perl_cando_by_name_int
11888 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11890 char usrname[L_cuserid];
11891 struct dsc$descriptor_s usrdsc =
11892 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11893 char *vmsname = NULL, *fileified = NULL;
11894 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11895 unsigned short int retlen, trnlnm_iter_count;
11896 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11897 union prvdef curprv;
11898 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11899 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11900 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11901 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11902 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11904 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11906 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11908 static int profile_context = -1;
11910 if (!fname || !*fname) return FALSE;
11912 /* Make sure we expand logical names, since sys$check_access doesn't */
11913 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11914 if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11915 if (!strpbrk(fname,"/]>:")) {
11916 my_strlcpy(fileified, fname, VMS_MAXRSS);
11917 trnlnm_iter_count = 0;
11918 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11919 trnlnm_iter_count++;
11920 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11925 vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11926 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11927 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11928 /* Don't know if already in VMS format, so make sure */
11929 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11930 PerlMem_free(fileified);
11931 PerlMem_free(vmsname);
11936 my_strlcpy(vmsname, fname, VMS_MAXRSS);
11939 /* sys$check_access needs a file spec, not a directory spec.
11940 * flex_stat now will handle a null thread context during startup.
11943 retlen = namdsc.dsc$w_length = strlen(vmsname);
11944 if (vmsname[retlen-1] == ']'
11945 || vmsname[retlen-1] == '>'
11946 || vmsname[retlen-1] == ':'
11947 || (!flex_stat_int(vmsname, &st, 1) &&
11948 S_ISDIR(st.st_mode))) {
11950 if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11951 PerlMem_free(fileified);
11952 PerlMem_free(vmsname);
11961 retlen = namdsc.dsc$w_length = strlen(fname);
11962 namdsc.dsc$a_pointer = (char *)fname;
11965 case S_IXUSR: case S_IXGRP: case S_IXOTH:
11966 access = ARM$M_EXECUTE;
11967 flags = CHP$M_READ;
11969 case S_IRUSR: case S_IRGRP: case S_IROTH:
11970 access = ARM$M_READ;
11971 flags = CHP$M_READ | CHP$M_USEREADALL;
11973 case S_IWUSR: case S_IWGRP: case S_IWOTH:
11974 access = ARM$M_WRITE;
11975 flags = CHP$M_READ | CHP$M_WRITE;
11977 case S_IDUSR: case S_IDGRP: case S_IDOTH:
11978 access = ARM$M_DELETE;
11979 flags = CHP$M_READ | CHP$M_WRITE;
11982 if (fileified != NULL)
11983 PerlMem_free(fileified);
11984 if (vmsname != NULL)
11985 PerlMem_free(vmsname);
11989 /* Before we call $check_access, create a user profile with the current
11990 * process privs since otherwise it just uses the default privs from the
11991 * UAF and might give false positives or negatives. This only works on
11992 * VMS versions v6.0 and later since that's when sys$create_user_profile
11993 * became available.
11996 /* get current process privs and username */
11997 _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11998 _ckvmssts_noperl(iosb[0]);
12000 /* find out the space required for the profile */
12001 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12002 &usrprodsc.dsc$w_length,&profile_context));
12004 /* allocate space for the profile and get it filled in */
12005 usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
12006 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12007 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12008 &usrprodsc.dsc$w_length,&profile_context));
12010 /* use the profile to check access to the file; free profile & analyze results */
12011 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12012 PerlMem_free(usrprodsc.dsc$a_pointer);
12013 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12015 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
12016 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12017 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12018 set_vaxc_errno(retsts);
12019 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12020 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12021 else set_errno(ENOENT);
12022 if (fileified != NULL)
12023 PerlMem_free(fileified);
12024 if (vmsname != NULL)
12025 PerlMem_free(vmsname);
12028 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12029 if (fileified != NULL)
12030 PerlMem_free(fileified);
12031 if (vmsname != NULL)
12032 PerlMem_free(vmsname);
12035 _ckvmssts_noperl(retsts);
12037 if (fileified != NULL)
12038 PerlMem_free(fileified);
12039 if (vmsname != NULL)
12040 PerlMem_free(vmsname);
12041 return FALSE; /* Should never get here */
12045 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
12046 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12047 * subset of the applicable information.
12050 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12052 return cando_by_name_int
12053 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12054 } /* end of cando() */
12058 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12060 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12062 return cando_by_name_int(bit, effective, fname, 0);
12064 } /* end of cando_by_name() */
12068 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12070 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12072 if (!fstat(fd, &statbufp->crtl_stat)) {
12074 char *vms_filename;
12075 vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12076 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12078 /* Save name for cando by name in VMS format */
12079 cptr = getname(fd, vms_filename, 1);
12081 /* This should not happen, but just in case */
12082 if (cptr == NULL) {
12083 statbufp->st_devnam[0] = 0;
12086 /* Make sure that the saved name fits in 255 characters */
12087 cptr = int_rmsexpand_vms
12089 statbufp->st_devnam,
12092 statbufp->st_devnam[0] = 0;
12094 PerlMem_free(vms_filename);
12096 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12098 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12100 # ifdef VMSISH_TIME
12102 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12103 statbufp->st_atime = _toloc(statbufp->st_atime);
12104 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12111 } /* end of flex_fstat() */
12115 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12117 char *temp_fspec = NULL;
12118 char *fileified = NULL;
12119 const char *save_spec;
12123 char already_fileified = 0;
12131 if (decc_bug_devnull != 0) {
12132 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12133 memset(statbufp,0,sizeof *statbufp);
12134 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12135 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12136 statbufp->st_uid = 0x00010001;
12137 statbufp->st_gid = 0x0001;
12138 time((time_t *)&statbufp->st_mtime);
12139 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12146 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12148 * If we are in POSIX filespec mode, accept the filename as is.
12150 if (decc_posix_compliant_pathnames == 0) {
12153 /* Try for a simple stat first. If fspec contains a filename without
12154 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12155 * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12156 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12157 * not sea:[wine.dark]., if the latter exists. If the intended target is
12158 * the file with null type, specify this by calling flex_stat() with
12159 * a '.' at the end of fspec.
12162 if (lstat_flag == 0)
12163 retval = stat(fspec, &statbufp->crtl_stat);
12165 retval = lstat(fspec, &statbufp->crtl_stat);
12171 /* In the odd case where we have write but not read access
12172 * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12174 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12175 if (fileified == NULL)
12176 _ckvmssts_noperl(SS$_INSFMEM);
12178 ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12179 if (ret_spec != NULL) {
12180 if (lstat_flag == 0)
12181 retval = stat(fileified, &statbufp->crtl_stat);
12183 retval = lstat(fileified, &statbufp->crtl_stat);
12184 save_spec = fileified;
12185 already_fileified = 1;
12189 if (retval && vms_bug_stat_filename) {
12191 temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12192 if (temp_fspec == NULL)
12193 _ckvmssts_noperl(SS$_INSFMEM);
12195 /* We should try again as a vmsified file specification. */
12197 ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12198 if (ret_spec != NULL) {
12199 if (lstat_flag == 0)
12200 retval = stat(temp_fspec, &statbufp->crtl_stat);
12202 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12203 save_spec = temp_fspec;
12208 /* Last chance - allow multiple dots without EFS CHARSET */
12209 /* The CRTL stat() falls down hard on multi-dot filenames in unix
12210 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12211 * enable it if it isn't already.
12213 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12214 if (!decc_efs_charset && (decc_efs_charset_index > 0))
12215 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12217 if (lstat_flag == 0)
12218 retval = stat(fspec, &statbufp->crtl_stat);
12220 retval = lstat(fspec, &statbufp->crtl_stat);
12222 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12223 if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12224 decc$feature_set_value(decc_efs_charset_index, 1, 0);
12230 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12232 if (lstat_flag == 0)
12233 retval = stat(temp_fspec, &statbufp->crtl_stat);
12235 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12236 save_spec = temp_fspec;
12240 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12241 /* As you were... */
12242 if (!decc_efs_charset)
12243 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12248 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12250 /* If this is an lstat, do not follow the link */
12252 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12254 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12255 /* If we used the efs_hack above, we must also use it here for */
12256 /* perl_cando to work */
12257 if (efs_hack && (decc_efs_charset_index > 0)) {
12258 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12262 /* If we've got a directory, save a fileified, expanded version of it
12263 * in st_devnam. If not a directory, just an expanded version.
12265 if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12266 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12267 if (fileified == NULL)
12268 _ckvmssts_noperl(SS$_INSFMEM);
12270 cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12272 save_spec = fileified;
12275 cptr = int_rmsexpand(save_spec,
12276 statbufp->st_devnam,
12282 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12283 if (efs_hack && (decc_efs_charset_index > 0)) {
12284 decc$feature_set_value(decc_efs_charset, 1, 0);
12288 /* Fix me: If this is NULL then stat found a file, and we could */
12289 /* not convert the specification to VMS - Should never happen */
12291 statbufp->st_devnam[0] = 0;
12293 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12295 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12296 # ifdef VMSISH_TIME
12298 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12299 statbufp->st_atime = _toloc(statbufp->st_atime);
12300 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12304 /* If we were successful, leave errno where we found it */
12305 if (retval == 0) RESTORE_ERRNO;
12307 PerlMem_free(temp_fspec);
12309 PerlMem_free(fileified);
12312 } /* end of flex_stat_int() */
12315 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12317 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12319 return flex_stat_int(fspec, statbufp, 0);
12323 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12325 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12327 return flex_stat_int(fspec, statbufp, 1);
12332 /*{{{char *my_getlogin()*/
12333 /* VMS cuserid == Unix getlogin, except calling sequence */
12337 static char user[L_cuserid];
12338 return cuserid(user);
12343 /* rmscopy - copy a file using VMS RMS routines
12345 * Copies contents and attributes of spec_in to spec_out, except owner
12346 * and protection information. Name and type of spec_in are used as
12347 * defaults for spec_out. The third parameter specifies whether rmscopy()
12348 * should try to propagate timestamps from the input file to the output file.
12349 * If it is less than 0, no timestamps are preserved. If it is 0, then
12350 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12351 * propagated to the output file at creation iff the output file specification
12352 * did not contain an explicit name or type, and the revision date is always
12353 * updated at the end of the copy operation. If it is greater than 0, then
12354 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12355 * other than the revision date should be propagated, and bit 1 indicates
12356 * that the revision date should be propagated.
12358 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12360 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12361 * Incorporates, with permission, some code from EZCOPY by Tim Adye
12362 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12363 * as part of the Perl standard distribution under the terms of the
12364 * GNU General Public License or the Perl Artistic License. Copies
12365 * of each may be found in the Perl standard distribution.
12367 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12369 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12371 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12372 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12373 unsigned long int sts;
12375 struct FAB fab_in, fab_out;
12376 struct RAB rab_in, rab_out;
12377 rms_setup_nam(nam);
12378 rms_setup_nam(nam_out);
12379 struct XABDAT xabdat;
12380 struct XABFHC xabfhc;
12381 struct XABRDT xabrdt;
12382 struct XABSUM xabsum;
12384 vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12385 if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12386 vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12387 if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12388 if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12389 !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12390 PerlMem_free(vmsin);
12391 PerlMem_free(vmsout);
12392 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12396 esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12397 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12399 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12400 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12401 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12403 fab_in = cc$rms_fab;
12404 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12405 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12406 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12407 fab_in.fab$l_fop = FAB$M_SQO;
12408 rms_bind_fab_nam(fab_in, nam);
12409 fab_in.fab$l_xab = (void *) &xabdat;
12411 rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12412 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12414 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12415 rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12416 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12418 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12419 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12420 rms_nam_esl(nam) = 0;
12421 rms_nam_rsl(nam) = 0;
12422 rms_nam_esll(nam) = 0;
12423 rms_nam_rsll(nam) = 0;
12424 #ifdef NAM$M_NO_SHORT_UPCASE
12425 if (decc_efs_case_preserve)
12426 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12429 xabdat = cc$rms_xabdat; /* To get creation date */
12430 xabdat.xab$l_nxt = (void *) &xabfhc;
12432 xabfhc = cc$rms_xabfhc; /* To get record length */
12433 xabfhc.xab$l_nxt = (void *) &xabsum;
12435 xabsum = cc$rms_xabsum; /* To get key and area information */
12437 if (!((sts = sys$open(&fab_in)) & 1)) {
12438 PerlMem_free(vmsin);
12439 PerlMem_free(vmsout);
12442 PerlMem_free(esal);
12445 PerlMem_free(rsal);
12446 set_vaxc_errno(sts);
12448 case RMS$_FNF: case RMS$_DNF:
12449 set_errno(ENOENT); break;
12451 set_errno(ENOTDIR); break;
12453 set_errno(ENODEV); break;
12455 set_errno(EINVAL); break;
12457 set_errno(EACCES); break;
12459 set_errno(EVMSERR);
12466 fab_out.fab$w_ifi = 0;
12467 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12468 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12469 fab_out.fab$l_fop = FAB$M_SQO;
12470 rms_bind_fab_nam(fab_out, nam_out);
12471 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12472 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12473 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12474 esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12475 if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12476 rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12477 if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12480 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12481 esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12482 if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12483 rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12484 if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12486 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12487 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12489 if (preserve_dates == 0) { /* Act like DCL COPY */
12490 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12491 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
12492 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12493 PerlMem_free(vmsin);
12494 PerlMem_free(vmsout);
12497 PerlMem_free(esal);
12500 PerlMem_free(rsal);
12501 PerlMem_free(esa_out);
12502 if (esal_out != NULL)
12503 PerlMem_free(esal_out);
12504 PerlMem_free(rsa_out);
12505 if (rsal_out != NULL)
12506 PerlMem_free(rsal_out);
12507 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12508 set_vaxc_errno(sts);
12511 fab_out.fab$l_xab = (void *) &xabdat;
12512 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12513 preserve_dates = 1;
12515 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12516 preserve_dates =0; /* bitmask from this point forward */
12518 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12519 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12520 PerlMem_free(vmsin);
12521 PerlMem_free(vmsout);
12524 PerlMem_free(esal);
12527 PerlMem_free(rsal);
12528 PerlMem_free(esa_out);
12529 if (esal_out != NULL)
12530 PerlMem_free(esal_out);
12531 PerlMem_free(rsa_out);
12532 if (rsal_out != NULL)
12533 PerlMem_free(rsal_out);
12534 set_vaxc_errno(sts);
12537 set_errno(ENOENT); break;
12539 set_errno(ENOTDIR); break;
12541 set_errno(ENODEV); break;
12543 set_errno(EINVAL); break;
12545 set_errno(EACCES); break;
12547 set_errno(EVMSERR);
12551 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12552 if (preserve_dates & 2) {
12553 /* sys$close() will process xabrdt, not xabdat */
12554 xabrdt = cc$rms_xabrdt;
12556 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12558 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12559 * is unsigned long[2], while DECC & VAXC use a struct */
12560 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12562 fab_out.fab$l_xab = (void *) &xabrdt;
12565 ubf = (char *)PerlMem_malloc(32256);
12566 if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12567 rab_in = cc$rms_rab;
12568 rab_in.rab$l_fab = &fab_in;
12569 rab_in.rab$l_rop = RAB$M_BIO;
12570 rab_in.rab$l_ubf = ubf;
12571 rab_in.rab$w_usz = 32256;
12572 if (!((sts = sys$connect(&rab_in)) & 1)) {
12573 sys$close(&fab_in); sys$close(&fab_out);
12574 PerlMem_free(vmsin);
12575 PerlMem_free(vmsout);
12579 PerlMem_free(esal);
12582 PerlMem_free(rsal);
12583 PerlMem_free(esa_out);
12584 if (esal_out != NULL)
12585 PerlMem_free(esal_out);
12586 PerlMem_free(rsa_out);
12587 if (rsal_out != NULL)
12588 PerlMem_free(rsal_out);
12589 set_errno(EVMSERR); set_vaxc_errno(sts);
12593 rab_out = cc$rms_rab;
12594 rab_out.rab$l_fab = &fab_out;
12595 rab_out.rab$l_rbf = ubf;
12596 if (!((sts = sys$connect(&rab_out)) & 1)) {
12597 sys$close(&fab_in); sys$close(&fab_out);
12598 PerlMem_free(vmsin);
12599 PerlMem_free(vmsout);
12603 PerlMem_free(esal);
12606 PerlMem_free(rsal);
12607 PerlMem_free(esa_out);
12608 if (esal_out != NULL)
12609 PerlMem_free(esal_out);
12610 PerlMem_free(rsa_out);
12611 if (rsal_out != NULL)
12612 PerlMem_free(rsal_out);
12613 set_errno(EVMSERR); set_vaxc_errno(sts);
12617 while ((sts = sys$read(&rab_in))) { /* always true */
12618 if (sts == RMS$_EOF) break;
12619 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12620 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12621 sys$close(&fab_in); sys$close(&fab_out);
12622 PerlMem_free(vmsin);
12623 PerlMem_free(vmsout);
12627 PerlMem_free(esal);
12630 PerlMem_free(rsal);
12631 PerlMem_free(esa_out);
12632 if (esal_out != NULL)
12633 PerlMem_free(esal_out);
12634 PerlMem_free(rsa_out);
12635 if (rsal_out != NULL)
12636 PerlMem_free(rsal_out);
12637 set_errno(EVMSERR); set_vaxc_errno(sts);
12643 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12644 sys$close(&fab_in); sys$close(&fab_out);
12645 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12647 PerlMem_free(vmsin);
12648 PerlMem_free(vmsout);
12652 PerlMem_free(esal);
12655 PerlMem_free(rsal);
12656 PerlMem_free(esa_out);
12657 if (esal_out != NULL)
12658 PerlMem_free(esal_out);
12659 PerlMem_free(rsa_out);
12660 if (rsal_out != NULL)
12661 PerlMem_free(rsal_out);
12664 set_errno(EVMSERR); set_vaxc_errno(sts);
12670 } /* end of rmscopy() */
12674 /*** The following glue provides 'hooks' to make some of the routines
12675 * from this file available from Perl. These routines are sufficiently
12676 * basic, and are required sufficiently early in the build process,
12677 * that's it's nice to have them available to miniperl as well as the
12678 * full Perl, so they're set up here instead of in an extension. The
12679 * Perl code which handles importation of these names into a given
12680 * package lives in [.VMS]Filespec.pm in @INC.
12684 rmsexpand_fromperl(pTHX_ CV *cv)
12687 char *fspec, *defspec = NULL, *rslt;
12689 int fs_utf8, dfs_utf8;
12693 if (!items || items > 2)
12694 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12695 fspec = SvPV(ST(0),n_a);
12696 fs_utf8 = SvUTF8(ST(0));
12697 if (!fspec || !*fspec) XSRETURN_UNDEF;
12699 defspec = SvPV(ST(1),n_a);
12700 dfs_utf8 = SvUTF8(ST(1));
12702 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12703 ST(0) = sv_newmortal();
12704 if (rslt != NULL) {
12705 sv_usepvn(ST(0),rslt,strlen(rslt));
12714 vmsify_fromperl(pTHX_ CV *cv)
12721 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12722 utf8_fl = SvUTF8(ST(0));
12723 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12724 ST(0) = sv_newmortal();
12725 if (vmsified != NULL) {
12726 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12735 unixify_fromperl(pTHX_ CV *cv)
12742 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12743 utf8_fl = SvUTF8(ST(0));
12744 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12745 ST(0) = sv_newmortal();
12746 if (unixified != NULL) {
12747 sv_usepvn(ST(0),unixified,strlen(unixified));
12756 fileify_fromperl(pTHX_ CV *cv)
12763 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12764 utf8_fl = SvUTF8(ST(0));
12765 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12766 ST(0) = sv_newmortal();
12767 if (fileified != NULL) {
12768 sv_usepvn(ST(0),fileified,strlen(fileified));
12777 pathify_fromperl(pTHX_ CV *cv)
12784 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12785 utf8_fl = SvUTF8(ST(0));
12786 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12787 ST(0) = sv_newmortal();
12788 if (pathified != NULL) {
12789 sv_usepvn(ST(0),pathified,strlen(pathified));
12798 vmspath_fromperl(pTHX_ CV *cv)
12805 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12806 utf8_fl = SvUTF8(ST(0));
12807 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12808 ST(0) = sv_newmortal();
12809 if (vmspath != NULL) {
12810 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12819 unixpath_fromperl(pTHX_ CV *cv)
12826 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12827 utf8_fl = SvUTF8(ST(0));
12828 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12829 ST(0) = sv_newmortal();
12830 if (unixpath != NULL) {
12831 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12840 candelete_fromperl(pTHX_ CV *cv)
12848 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12850 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12851 Newx(fspec, VMS_MAXRSS, char);
12852 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12853 if (isGV_with_GP(mysv)) {
12854 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12855 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12863 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12864 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12871 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12877 rmscopy_fromperl(pTHX_ CV *cv)
12880 char *inspec, *outspec, *inp, *outp;
12886 if (items < 2 || items > 3)
12887 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12889 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12890 Newx(inspec, VMS_MAXRSS, char);
12891 if (isGV_with_GP(mysv)) {
12892 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12893 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12894 ST(0) = sv_2mortal(newSViv(0));
12901 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12902 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12903 ST(0) = sv_2mortal(newSViv(0));
12908 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12909 Newx(outspec, VMS_MAXRSS, char);
12910 if (isGV_with_GP(mysv)) {
12911 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12912 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12913 ST(0) = sv_2mortal(newSViv(0));
12921 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12922 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12923 ST(0) = sv_2mortal(newSViv(0));
12929 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12931 ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12937 /* The mod2fname is limited to shorter filenames by design, so it should
12938 * not be modified to support longer EFS pathnames
12941 mod2fname(pTHX_ CV *cv)
12944 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12945 workbuff[NAM$C_MAXRSS*1 + 1];
12946 int counter, num_entries;
12947 /* ODS-5 ups this, but we want to be consistent, so... */
12948 int max_name_len = 39;
12949 AV *in_array = (AV *)SvRV(ST(0));
12951 num_entries = av_len(in_array);
12953 /* All the names start with PL_. */
12954 strcpy(ultimate_name, "PL_");
12956 /* Clean up our working buffer */
12957 Zero(work_name, sizeof(work_name), char);
12959 /* Run through the entries and build up a working name */
12960 for(counter = 0; counter <= num_entries; counter++) {
12961 /* If it's not the first name then tack on a __ */
12963 my_strlcat(work_name, "__", sizeof(work_name));
12965 my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12968 /* Check to see if we actually have to bother...*/
12969 if (strlen(work_name) + 3 <= max_name_len) {
12970 my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12972 /* It's too darned big, so we need to go strip. We use the same */
12973 /* algorithm as xsubpp does. First, strip out doubled __ */
12974 char *source, *dest, last;
12977 for (source = work_name; *source; source++) {
12978 if (last == *source && last == '_') {
12984 /* Go put it back */
12985 my_strlcpy(work_name, workbuff, sizeof(work_name));
12986 /* Is it still too big? */
12987 if (strlen(work_name) + 3 > max_name_len) {
12988 /* Strip duplicate letters */
12991 for (source = work_name; *source; source++) {
12992 if (last == toupper(*source)) {
12996 last = toupper(*source);
12998 my_strlcpy(work_name, workbuff, sizeof(work_name));
13001 /* Is it *still* too big? */
13002 if (strlen(work_name) + 3 > max_name_len) {
13003 /* Too bad, we truncate */
13004 work_name[max_name_len - 2] = 0;
13006 my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
13009 /* Okay, return it */
13010 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13015 hushexit_fromperl(pTHX_ CV *cv)
13020 VMSISH_HUSHED = SvTRUE(ST(0));
13022 ST(0) = boolSV(VMSISH_HUSHED);
13028 Perl_vms_start_glob
13029 (pTHX_ SV *tmpglob,
13033 struct vs_str_st *rslt;
13037 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13040 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13041 struct dsc$descriptor_vs rsdsc;
13042 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13043 unsigned long hasver = 0, isunix = 0;
13044 unsigned long int lff_flags = 0;
13046 int vms_old_glob = 1;
13048 if (!SvOK(tmpglob)) {
13049 SETERRNO(ENOENT,RMS$_FNF);
13053 vms_old_glob = !decc_filename_unix_report;
13055 #ifdef VMS_LONGNAME_SUPPORT
13056 lff_flags = LIB$M_FIL_LONG_NAMES;
13058 /* The Newx macro will not allow me to assign a smaller array
13059 * to the rslt pointer, so we will assign it to the begin char pointer
13060 * and then copy the value into the rslt pointer.
13062 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13063 rslt = (struct vs_str_st *)begin;
13065 rstr = &rslt->str[0];
13066 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13067 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13068 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13069 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13071 Newx(vmsspec, VMS_MAXRSS, char);
13073 /* We could find out if there's an explicit dev/dir or version
13074 by peeking into lib$find_file's internal context at
13075 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13076 but that's unsupported, so I don't want to do it now and
13077 have it bite someone in the future. */
13078 /* Fix-me: vms_split_path() is the only way to do this, the
13079 existing method will fail with many legal EFS or UNIX specifications
13082 cp = SvPV(tmpglob,i);
13085 if (cp[i] == ';') hasver = 1;
13086 if (cp[i] == '.') {
13087 if (sts) hasver = 1;
13090 if (cp[i] == '/') {
13091 hasdir = isunix = 1;
13094 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13100 /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13101 if ((hasdir == 0) && decc_filename_unix_report) {
13105 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13106 char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13107 int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13113 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13114 if (!stat_sts && S_ISDIR(st.st_mode)) {
13116 const char * fname;
13119 /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13120 /* path delimiter of ':>]', if so, then the old behavior has */
13121 /* obviously been specifically requested */
13123 fname = SvPVX_const(tmpglob);
13124 fname_len = strlen(fname);
13125 vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13126 if (vms_old_glob || (vms_dir != NULL)) {
13127 wilddsc.dsc$a_pointer = tovmspath_utf8(
13128 SvPVX(tmpglob),vmsspec,NULL);
13129 ok = (wilddsc.dsc$a_pointer != NULL);
13130 /* maybe passed 'foo' rather than '[.foo]', thus not
13134 /* Operate just on the directory, the special stat/fstat for */
13135 /* leaves the fileified specification in the st_devnam */
13137 wilddsc.dsc$a_pointer = st.st_devnam;
13142 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13143 ok = (wilddsc.dsc$a_pointer != NULL);
13146 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13148 /* If not extended character set, replace ? with % */
13149 /* With extended character set, ? is a wildcard single character */
13150 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13153 if (!decc_efs_charset)
13155 } else if (*cp == '%') {
13157 } else if (*cp == '*') {
13163 wv_sts = vms_split_path(
13164 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13165 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13166 &wvs_spec, &wvs_len);
13175 while (ok && $VMS_STATUS_SUCCESS(sts)) {
13176 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13177 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13181 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13182 &dfltdsc,NULL,&rms_sts,&lff_flags);
13183 if (!$VMS_STATUS_SUCCESS(sts))
13186 /* with varying string, 1st word of buffer contains result length */
13187 rstr[rslt->length] = '\0';
13189 /* Find where all the components are */
13190 v_sts = vms_split_path
13205 /* If no version on input, truncate the version on output */
13206 if (!hasver && (vs_len > 0)) {
13213 /* In Unix report mode, remove the ".dir;1" from the name */
13214 /* if it is a real directory */
13215 if (decc_filename_unix_report || decc_efs_charset) {
13216 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13220 ret_sts = flex_lstat(rstr, &statbuf);
13221 if ((ret_sts == 0) &&
13222 S_ISDIR(statbuf.st_mode)) {
13229 /* No version & a null extension on UNIX handling */
13230 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13236 if (!decc_efs_case_preserve) {
13237 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13240 /* Find File treats a Null extension as return all extensions */
13241 /* This is contrary to Perl expectations */
13243 if (wildstar || wildquery || vms_old_glob) {
13244 /* really need to see if the returned file name matched */
13245 /* but for now will assume that it matches */
13248 /* Exact Match requested */
13249 /* How are directories handled? - like a file */
13250 if ((e_len == we_len) && (n_len == wn_len)) {
13254 t1 = strncmp(e_spec, we_spec, e_len);
13258 t1 = strncmp(n_spec, we_spec, n_len);
13269 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13273 /* Start with the name */
13276 strcat(begin,"\n");
13277 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13280 if (cxt) (void)lib$find_file_end(&cxt);
13283 /* Be POSIXish: return the input pattern when no matches */
13284 my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13286 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13289 if (ok && sts != RMS$_NMF &&
13290 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13293 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13295 PerlIO_close(tmpfp);
13299 PerlIO_rewind(tmpfp);
13300 IoTYPE(io) = IoTYPE_RDONLY;
13301 IoIFP(io) = fp = tmpfp;
13302 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
13312 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13316 unixrealpath_fromperl(pTHX_ CV *cv)
13319 char *fspec, *rslt_spec, *rslt;
13322 if (!items || items != 1)
13323 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13325 fspec = SvPV(ST(0),n_a);
13326 if (!fspec || !*fspec) XSRETURN_UNDEF;
13328 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13329 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13331 ST(0) = sv_newmortal();
13333 sv_usepvn(ST(0),rslt,strlen(rslt));
13335 Safefree(rslt_spec);
13340 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13344 vmsrealpath_fromperl(pTHX_ CV *cv)
13347 char *fspec, *rslt_spec, *rslt;
13350 if (!items || items != 1)
13351 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13353 fspec = SvPV(ST(0),n_a);
13354 if (!fspec || !*fspec) XSRETURN_UNDEF;
13356 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13357 rslt = do_vms_realname(fspec, rslt_spec, NULL);
13359 ST(0) = sv_newmortal();
13361 sv_usepvn(ST(0),rslt,strlen(rslt));
13363 Safefree(rslt_spec);
13369 * A thin wrapper around decc$symlink to make sure we follow the
13370 * standard and do not create a symlink with a zero-length name,
13371 * and convert the target to Unix format, as the CRTL can't handle
13372 * targets in VMS format.
13374 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13376 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13381 if (!link_name || !*link_name) {
13382 SETERRNO(ENOENT, SS$_NOSUCHFILE);
13386 utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13387 /* An untranslatable filename should be passed through. */
13388 (void) int_tounixspec(contents, utarget, NULL);
13389 sts = symlink(utarget, link_name);
13390 PerlMem_free(utarget);
13395 #endif /* HAS_SYMLINK */
13397 int do_vms_case_tolerant(void);
13400 case_tolerant_process_fromperl(pTHX_ CV *cv)
13403 ST(0) = boolSV(do_vms_case_tolerant());
13407 #ifdef USE_ITHREADS
13410 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13411 struct interp_intern *dst)
13413 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13415 memcpy(dst,src,sizeof(struct interp_intern));
13421 Perl_sys_intern_clear(pTHX)
13426 Perl_sys_intern_init(pTHX)
13428 unsigned int ix = RAND_MAX;
13433 MY_POSIX_EXIT = vms_posix_exit;
13436 MY_INV_RAND_MAX = 1./x;
13440 init_os_extras(void)
13443 char* file = __FILE__;
13444 if (decc_disable_to_vms_logname_translation) {
13445 no_translate_barewords = TRUE;
13447 no_translate_barewords = FALSE;
13450 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13451 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13452 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13453 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13454 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13455 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13456 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13457 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13458 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13459 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13460 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13461 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13462 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13463 newXSproto("VMS::Filespec::case_tolerant_process",
13464 case_tolerant_process_fromperl,file,"");
13466 store_pipelocs(aTHX); /* will redo any earlier attempts */
13471 #if __CRTL_VER == 80200000
13472 /* This missed getting in to the DECC SDK for 8.2 */
13473 char *realpath(const char *file_name, char * resolved_name, ...);
13476 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13477 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13478 * The perl fallback routine to provide realpath() is not as efficient
13486 /* Hack, use old stat() as fastest way of getting ino_t and device */
13487 int decc$stat(const char *name, void * statbuf);
13488 #if !defined(__VAX) && __CRTL_VER >= 80200000
13489 int decc$lstat(const char *name, void * statbuf);
13491 #define decc$lstat decc$stat
13499 /* Realpath is fragile. In 8.3 it does not work if the feature
13500 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13501 * links are implemented in RMS, not the CRTL. It also can fail if the
13502 * user does not have read/execute access to some of the directories.
13503 * So in order for Do What I Mean mode to work, if realpath() fails,
13504 * fall back to looking up the filename by the device name and FID.
13507 int vms_fid_to_name(char * outname, int outlen,
13508 const char * name, int lstat_flag, mode_t * mode)
13510 #pragma message save
13511 #pragma message disable MISALGNDSTRCT
13512 #pragma message disable MISALGNDMEM
13513 #pragma member_alignment save
13514 #pragma nomember_alignment
13517 unsigned short st_ino[3];
13518 unsigned short old_st_mode;
13519 unsigned long padl[30]; /* plenty of room */
13521 #pragma message restore
13522 #pragma member_alignment restore
13525 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13526 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13531 /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13532 * unexpected answers
13535 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13536 if (fileified == NULL)
13537 _ckvmssts_noperl(SS$_INSFMEM);
13539 temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13540 if (temp_fspec == NULL)
13541 _ckvmssts_noperl(SS$_INSFMEM);
13544 /* First need to try as a directory */
13545 ret_spec = int_tovmspath(name, temp_fspec, NULL);
13546 if (ret_spec != NULL) {
13547 ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13548 if (ret_spec != NULL) {
13549 if (lstat_flag == 0)
13550 sts = decc$stat(fileified, &statbuf);
13552 sts = decc$lstat(fileified, &statbuf);
13556 /* Then as a VMS file spec */
13558 ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13559 if (ret_spec != NULL) {
13560 if (lstat_flag == 0) {
13561 sts = decc$stat(temp_fspec, &statbuf);
13563 sts = decc$lstat(temp_fspec, &statbuf);
13569 /* Next try - allow multiple dots with out EFS CHARSET */
13570 /* The CRTL stat() falls down hard on multi-dot filenames in unix
13571 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13572 * enable it if it isn't already.
13574 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13575 if (!decc_efs_charset && (decc_efs_charset_index > 0))
13576 decc$feature_set_value(decc_efs_charset_index, 1, 1);
13578 ret_spec = int_tovmspath(name, temp_fspec, NULL);
13579 if (lstat_flag == 0) {
13580 sts = decc$stat(name, &statbuf);
13582 sts = decc$lstat(name, &statbuf);
13584 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13585 if (!decc_efs_charset && (decc_efs_charset_index > 0))
13586 decc$feature_set_value(decc_efs_charset_index, 1, 0);
13591 /* and then because the Perl Unix to VMS conversion is not perfect */
13592 /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13593 /* characters from filenames so we need to try it as-is */
13595 if (lstat_flag == 0) {
13596 sts = decc$stat(name, &statbuf);
13598 sts = decc$lstat(name, &statbuf);
13605 dvidsc.dsc$a_pointer=statbuf.st_dev;
13606 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13608 specdsc.dsc$a_pointer = outname;
13609 specdsc.dsc$w_length = outlen-1;
13611 vms_sts = lib$fid_to_name
13612 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13613 if ($VMS_STATUS_SUCCESS(vms_sts)) {
13614 outname[specdsc.dsc$w_length] = 0;
13616 /* Return the mode */
13618 *mode = statbuf.old_st_mode;
13622 PerlMem_free(temp_fspec);
13623 PerlMem_free(fileified);
13630 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13633 char * rslt = NULL;
13636 if (decc_posix_compliant_pathnames > 0 ) {
13637 /* realpath currently only works if posix compliant pathnames are
13638 * enabled. It may start working when they are not, but in that
13639 * case we still want the fallback behavior for backwards compatibility
13641 rslt = realpath(filespec, outbuf);
13645 if (rslt == NULL) {
13647 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13648 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13651 /* Fall back to fid_to_name */
13653 Newx(vms_spec, VMS_MAXRSS + 1, char);
13655 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13659 /* Now need to trim the version off */
13660 sts = vms_split_path
13680 /* Trim off the version */
13681 int file_len = v_len + r_len + d_len + n_len + e_len;
13682 vms_spec[file_len] = 0;
13684 /* Trim off the .DIR if this is a directory */
13685 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13686 if (S_ISDIR(my_mode)) {
13692 /* Drop NULL extensions on UNIX file specification */
13693 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13698 /* The result is expected to be in UNIX format */
13699 rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13701 /* Downcase if input had any lower case letters and
13702 * case preservation is not in effect.
13704 if (!decc_efs_case_preserve) {
13705 for (cp = filespec; *cp; cp++)
13706 if (islower(*cp)) { haslower = 1; break; }
13708 if (haslower) __mystrtolower(rslt);
13713 /* Now for some hacks to deal with backwards and forward */
13714 /* compatibility */
13715 if (!decc_efs_charset) {
13717 /* 1. ODS-2 mode wants to do a syntax only translation */
13718 rslt = int_rmsexpand(filespec, outbuf,
13719 NULL, 0, NULL, utf8_fl);
13722 if (decc_filename_unix_report) {
13724 char * vms_dir_name;
13727 /* 2. ODS-5 / UNIX report mode should return a failure */
13728 /* if the parent directory also does not exist */
13729 /* Otherwise, get the real path for the parent */
13730 /* and add the child to it. */
13732 /* basename / dirname only available for VMS 7.0+ */
13733 /* So we may need to implement them as common routines */
13735 Newx(dir_name, VMS_MAXRSS + 1, char);
13736 Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13737 dir_name[0] = '\0';
13740 /* First try a VMS parse */
13741 sts = vms_split_path
13759 int dir_len = v_len + r_len + d_len + n_len;
13761 memcpy(dir_name, filespec, dir_len);
13762 dir_name[dir_len] = '\0';
13763 file_name = (char *)&filespec[dir_len + 1];
13766 /* This must be UNIX */
13769 tchar = strrchr(filespec, '/');
13771 if (tchar != NULL) {
13772 int dir_len = tchar - filespec;
13773 memcpy(dir_name, filespec, dir_len);
13774 dir_name[dir_len] = '\0';
13775 file_name = (char *) &filespec[dir_len + 1];
13779 /* Dir name is defaulted */
13780 if (dir_name[0] == 0) {
13782 dir_name[1] = '\0';
13785 /* Need realpath for the directory */
13786 sts = vms_fid_to_name(vms_dir_name,
13788 dir_name, 0, NULL);
13791 /* Now need to pathify it. */
13792 char *tdir = int_pathify_dirspec(vms_dir_name,
13795 /* And now add the original filespec to it */
13796 if (file_name != NULL) {
13797 my_strlcat(outbuf, file_name, VMS_MAXRSS);
13801 Safefree(vms_dir_name);
13802 Safefree(dir_name);
13806 Safefree(vms_spec);
13812 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13815 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13816 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13818 /* Fall back to fid_to_name */
13820 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13827 /* Now need to trim the version off */
13828 sts = vms_split_path
13848 /* Trim off the version */
13849 int file_len = v_len + r_len + d_len + n_len + e_len;
13850 outbuf[file_len] = 0;
13852 /* Downcase if input had any lower case letters and
13853 * case preservation is not in effect.
13855 if (!decc_efs_case_preserve) {
13856 for (cp = filespec; *cp; cp++)
13857 if (islower(*cp)) { haslower = 1; break; }
13859 if (haslower) __mystrtolower(outbuf);
13868 /* External entry points */
13869 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13870 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13872 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13873 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13875 /* case_tolerant */
13877 /*{{{int do_vms_case_tolerant(void)*/
13878 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13879 * controlled by a process setting.
13881 int do_vms_case_tolerant(void)
13883 return vms_process_case_tolerant;
13886 /* External entry points */
13887 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13888 int Perl_vms_case_tolerant(void)
13889 { return do_vms_case_tolerant(); }
13891 int Perl_vms_case_tolerant(void)
13892 { return vms_process_case_tolerant; }
13896 /* Start of DECC RTL Feature handling */
13899 /* C RTL Feature settings */
13901 #if defined(__DECC) || defined(__DECCXX)
13908 vmsperl_set_features(void)
13913 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13914 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13915 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13916 unsigned long case_perm;
13917 unsigned long case_image;
13920 /* Allow an exception to bring Perl into the VMS debugger */
13921 vms_debug_on_exception = 0;
13922 status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13923 if ($VMS_STATUS_SUCCESS(status)) {
13924 val_str[0] = _toupper(val_str[0]);
13925 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13926 vms_debug_on_exception = 1;
13928 vms_debug_on_exception = 0;
13931 /* Debug unix/vms file translation routines */
13932 vms_debug_fileify = 0;
13933 status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13934 if ($VMS_STATUS_SUCCESS(status)) {
13935 val_str[0] = _toupper(val_str[0]);
13936 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13937 vms_debug_fileify = 1;
13939 vms_debug_fileify = 0;
13943 /* Historically PERL has been doing vmsify / stat differently than */
13944 /* the CRTL. In particular, under some conditions the CRTL will */
13945 /* remove some illegal characters like spaces from filenames */
13946 /* resulting in some differences. The stat()/lstat() wrapper has */
13947 /* been reporting such file names as invalid and fails to stat them */
13948 /* fixing this bug so that stat()/lstat() accept these like the */
13949 /* CRTL does will result in several tests failing. */
13950 /* This should really be fixed, but for now, set up a feature to */
13951 /* enable it so that the impact can be studied. */
13952 vms_bug_stat_filename = 0;
13953 status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13954 if ($VMS_STATUS_SUCCESS(status)) {
13955 val_str[0] = _toupper(val_str[0]);
13956 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13957 vms_bug_stat_filename = 1;
13959 vms_bug_stat_filename = 0;
13963 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13964 vms_vtf7_filenames = 0;
13965 status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13966 if ($VMS_STATUS_SUCCESS(status)) {
13967 val_str[0] = _toupper(val_str[0]);
13968 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13969 vms_vtf7_filenames = 1;
13971 vms_vtf7_filenames = 0;
13974 /* unlink all versions on unlink() or rename() */
13975 vms_unlink_all_versions = 0;
13976 status = simple_trnlnm
13977 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13978 if ($VMS_STATUS_SUCCESS(status)) {
13979 val_str[0] = _toupper(val_str[0]);
13980 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13981 vms_unlink_all_versions = 1;
13983 vms_unlink_all_versions = 0;
13986 /* Dectect running under GNV Bash or other UNIX like shell */
13987 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13988 gnv_unix_shell = 0;
13989 status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13990 if ($VMS_STATUS_SUCCESS(status)) {
13991 gnv_unix_shell = 1;
13992 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13993 set_feature_default("DECC$EFS_CHARSET", 1);
13994 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13995 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13996 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13997 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13998 vms_unlink_all_versions = 1;
13999 vms_posix_exit = 1;
14003 /* hacks to see if known bugs are still present for testing */
14005 /* PCP mode requires creating /dev/null special device file */
14006 decc_bug_devnull = 0;
14007 status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14008 if ($VMS_STATUS_SUCCESS(status)) {
14009 val_str[0] = _toupper(val_str[0]);
14010 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14011 decc_bug_devnull = 1;
14013 decc_bug_devnull = 0;
14016 /* UNIX directory names with no paths are broken in a lot of places */
14017 decc_dir_barename = 1;
14018 status = simple_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14019 if ($VMS_STATUS_SUCCESS(status)) {
14020 val_str[0] = _toupper(val_str[0]);
14021 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14022 decc_dir_barename = 1;
14024 decc_dir_barename = 0;
14027 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14028 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14030 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14031 if (decc_disable_to_vms_logname_translation < 0)
14032 decc_disable_to_vms_logname_translation = 0;
14035 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14037 decc_efs_case_preserve = decc$feature_get_value(s, 1);
14038 if (decc_efs_case_preserve < 0)
14039 decc_efs_case_preserve = 0;
14042 s = decc$feature_get_index("DECC$EFS_CHARSET");
14043 decc_efs_charset_index = s;
14045 decc_efs_charset = decc$feature_get_value(s, 1);
14046 if (decc_efs_charset < 0)
14047 decc_efs_charset = 0;
14050 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14052 decc_filename_unix_report = decc$feature_get_value(s, 1);
14053 if (decc_filename_unix_report > 0) {
14054 decc_filename_unix_report = 1;
14055 vms_posix_exit = 1;
14058 decc_filename_unix_report = 0;
14061 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14063 decc_filename_unix_only = decc$feature_get_value(s, 1);
14064 if (decc_filename_unix_only > 0) {
14065 decc_filename_unix_only = 1;
14068 decc_filename_unix_only = 0;
14072 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14074 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14075 if (decc_filename_unix_no_version < 0)
14076 decc_filename_unix_no_version = 0;
14079 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14081 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14082 if (decc_readdir_dropdotnotype < 0)
14083 decc_readdir_dropdotnotype = 0;
14086 #if __CRTL_VER >= 80200000
14087 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14089 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14090 if (decc_posix_compliant_pathnames < 0)
14091 decc_posix_compliant_pathnames = 0;
14092 if (decc_posix_compliant_pathnames > 4)
14093 decc_posix_compliant_pathnames = 0;
14098 status = simple_trnlnm
14099 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14100 if ($VMS_STATUS_SUCCESS(status)) {
14101 val_str[0] = _toupper(val_str[0]);
14102 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14103 decc_disable_to_vms_logname_translation = 1;
14108 status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14109 if ($VMS_STATUS_SUCCESS(status)) {
14110 val_str[0] = _toupper(val_str[0]);
14111 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14112 decc_efs_case_preserve = 1;
14117 status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14118 if ($VMS_STATUS_SUCCESS(status)) {
14119 val_str[0] = _toupper(val_str[0]);
14120 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14121 decc_filename_unix_report = 1;
14124 status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14125 if ($VMS_STATUS_SUCCESS(status)) {
14126 val_str[0] = _toupper(val_str[0]);
14127 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14128 decc_filename_unix_only = 1;
14129 decc_filename_unix_report = 1;
14132 status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14133 if ($VMS_STATUS_SUCCESS(status)) {
14134 val_str[0] = _toupper(val_str[0]);
14135 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14136 decc_filename_unix_no_version = 1;
14139 status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14140 if ($VMS_STATUS_SUCCESS(status)) {
14141 val_str[0] = _toupper(val_str[0]);
14142 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14143 decc_readdir_dropdotnotype = 1;
14148 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14150 /* Report true case tolerance */
14151 /*----------------------------*/
14152 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14153 if (!$VMS_STATUS_SUCCESS(status))
14154 case_perm = PPROP$K_CASE_BLIND;
14155 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14156 if (!$VMS_STATUS_SUCCESS(status))
14157 case_image = PPROP$K_CASE_BLIND;
14158 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14159 (case_image == PPROP$K_CASE_SENSITIVE))
14160 vms_process_case_tolerant = 0;
14164 /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
14165 /* for strict backward compatibility */
14166 status = simple_trnlnm
14167 ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14168 if ($VMS_STATUS_SUCCESS(status)) {
14169 val_str[0] = _toupper(val_str[0]);
14170 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14171 vms_posix_exit = 1;
14173 vms_posix_exit = 0;
14177 /* Use 32-bit pointers because that's what the image activator
14178 * assumes for the LIB$INITIALZE psect.
14180 #if __INITIAL_POINTER_SIZE
14181 #pragma pointer_size save
14182 #pragma pointer_size 32
14185 /* Create a reference to the LIB$INITIALIZE function. */
14186 extern void LIB$INITIALIZE(void);
14187 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14189 /* Create an array of pointers to the init functions in the special
14190 * LIB$INITIALIZE section. In our case, the array only has one entry.
14192 #pragma extern_model save
14193 #pragma extern_model strict_refdef "LIB$INITIALIZE" gbl,noexe,nowrt,noshr,long
14194 extern void (* const vmsperl_unused_global_2[])() =
14196 vmsperl_set_features,
14198 #pragma extern_model restore
14200 #if __INITIAL_POINTER_SIZE
14201 #pragma pointer_size restore
14208 #endif /* defined(__DECC) || defined(__DECCXX) */