3 * VMS-specific routines for perl5
5 * Copyright (C) 1993-2015 by Charles Bailey and others.
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
12 * Yet small as was their hunted band
13 * still fell and fearless was each hand,
14 * and strong deeds they wrought yet oft,
15 * and loved the woods, whose ways more soft
16 * them seemed than thralls of that black throne
17 * to live and languish in halls of stone.
18 * "The Lay of Leithian", Canto II, lines 135-40
20 * [p.162 of _The Lays of Beleriand_]
28 #include <climsgdef.h>
38 #include <libclidef.h>
40 #include <lib$routines.h>
52 #include <str$routines.h>
58 #define NO_EFN EFN$C_ENF
62 #pragma member_alignment save
63 #pragma nomember_alignment longword
68 unsigned short * retadr;
70 #pragma member_alignment restore
72 /* Older versions of ssdef.h don't have these */
73 #ifndef SS$_INVFILFOROP
74 # define SS$_INVFILFOROP 3930
76 #ifndef SS$_NOSUCHOBJECT
77 # define SS$_NOSUCHOBJECT 2696
80 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
81 #define PERLIO_NOT_STDIO 0
83 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
84 * code below needs to get to the underlying CRTL routines. */
85 #define DONT_MASK_RTL_CALLS
89 /* Anticipating future expansion in lexical warnings . . . */
91 # define WARN_INTERNAL WARN_MISC
94 #ifdef VMS_LONGNAME_SUPPORT
95 #include <libfildef.h>
98 #if __CRTL_VER >= 80200000
106 #define lstat(_x, _y) stat(_x, _y)
109 /* Routine to create a decterm for use with the Perl debugger */
110 /* No headers, this information was found in the Programming Concepts Manual */
112 static int (*decw_term_port)
113 (const struct dsc$descriptor_s * display,
114 const struct dsc$descriptor_s * setup_file,
115 const struct dsc$descriptor_s * customization,
116 struct dsc$descriptor_s * result_device_name,
117 unsigned short * result_device_name_length,
120 void * char_change_buffer) = 0;
122 #if defined(NEED_AN_H_ERRNO)
126 #if defined(__DECC) || defined(__DECCXX)
127 #pragma member_alignment save
128 #pragma nomember_alignment longword
130 #pragma message disable misalgndmem
133 unsigned short int buflen;
134 unsigned short int itmcode;
136 unsigned short int *retlen;
139 struct filescan_itmlst_2 {
140 unsigned short length;
141 unsigned short itmcode;
146 unsigned short length;
147 char str[VMS_MAXRSS];
148 unsigned short pad; /* for longword struct alignment */
151 #if defined(__DECC) || defined(__DECCXX)
152 #pragma message restore
153 #pragma member_alignment restore
156 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
157 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
158 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
159 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
160 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
161 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
162 #define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
163 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
164 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
165 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
166 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
167 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
169 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
170 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
171 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
172 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
174 static char * int_rmsexpand_vms(
175 const char * filespec, char * outbuf, unsigned opts);
176 static char * int_rmsexpand_tovms(
177 const char * filespec, char * outbuf, unsigned opts);
178 static char *int_tovmsspec
179 (const char *path, char *buf, int dir_flag, int * utf8_flag);
180 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
181 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
182 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
184 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
185 #define PERL_LNM_MAX_ALLOWED_INDEX 127
187 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
188 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
191 #define PERL_LNM_MAX_ITER 10
193 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
194 #define MAX_DCL_SYMBOL (8192)
195 #define MAX_DCL_LINE_LENGTH (4096 - 4)
197 static char *__mystrtolower(char *str)
199 if (str) for (; *str; ++str) *str= tolower(*str);
203 static struct dsc$descriptor_s fildevdsc =
204 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
205 static struct dsc$descriptor_s crtlenvdsc =
206 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
207 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
208 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
209 static struct dsc$descriptor_s **env_tables = defenv;
210 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
212 /* True if we shouldn't treat barewords as logicals during directory */
214 static int no_translate_barewords;
216 /* DECC Features that may need to affect how Perl interprets
217 * displays filename information
219 static int decc_disable_to_vms_logname_translation = 1;
220 static int decc_disable_posix_root = 1;
221 int decc_efs_case_preserve = 0;
222 static int decc_efs_charset = 0;
223 static int decc_efs_charset_index = -1;
224 static int decc_filename_unix_no_version = 0;
225 static int decc_filename_unix_only = 0;
226 int decc_filename_unix_report = 0;
227 int decc_posix_compliant_pathnames = 0;
228 int decc_readdir_dropdotnotype = 0;
229 static int vms_process_case_tolerant = 1;
230 int vms_vtf7_filenames = 0;
231 int gnv_unix_shell = 0;
232 static int vms_unlink_all_versions = 0;
233 static int vms_posix_exit = 0;
235 /* bug workarounds if needed */
236 int decc_bug_devnull = 1;
237 int vms_bug_stat_filename = 0;
239 static int vms_debug_on_exception = 0;
240 static int vms_debug_fileify = 0;
242 /* Simple logical name translation */
244 simple_trnlnm(const char * logname, char * value, int value_len)
246 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
247 const unsigned long attr = LNM$M_CASE_BLIND;
248 struct dsc$descriptor_s name_dsc;
250 unsigned short result;
251 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
254 name_dsc.dsc$w_length = strlen(logname);
255 name_dsc.dsc$a_pointer = (char *)logname;
256 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
257 name_dsc.dsc$b_class = DSC$K_CLASS_S;
259 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
261 if ($VMS_STATUS_SUCCESS(status)) {
263 /* Null terminate and return the string */
264 /*--------------------------------------*/
273 /* Is this a UNIX file specification?
274 * No longer a simple check with EFS file specs
275 * For now, not a full check, but need to
276 * handle POSIX ^UP^ specifications
277 * Fixing to handle ^/ cases would require
278 * changes to many other conversion routines.
282 is_unix_filespec(const char *path)
288 if (strncmp(path,"\"^UP^",5) != 0) {
289 pch1 = strchr(path, '/');
294 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
295 if (decc_filename_unix_report || decc_filename_unix_only) {
296 if (strcmp(path,".") == 0)
304 /* This routine converts a UCS-2 character to be VTF-7 encoded.
308 ucs2_to_vtf7(char *outspec, unsigned long ucs2_char, int * output_cnt)
310 unsigned char * ucs_ptr;
313 ucs_ptr = (unsigned char *)&ucs2_char;
317 hex = (ucs_ptr[1] >> 4) & 0xf;
319 outspec[2] = hex + '0';
321 outspec[2] = (hex - 9) + 'A';
322 hex = ucs_ptr[1] & 0xF;
324 outspec[3] = hex + '0';
326 outspec[3] = (hex - 9) + 'A';
328 hex = (ucs_ptr[0] >> 4) & 0xf;
330 outspec[4] = hex + '0';
332 outspec[4] = (hex - 9) + 'A';
333 hex = ucs_ptr[1] & 0xF;
335 outspec[5] = hex + '0';
337 outspec[5] = (hex - 9) + 'A';
343 /* This handles the conversion of a UNIX extended character set to a ^
344 * escaped VMS character.
345 * in a UNIX file specification.
347 * The output count variable contains the number of characters added
348 * to the output string.
350 * The return value is the number of characters read from the input string
353 copy_expand_unix_filename_escape(char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
360 utf8_flag = *utf8_fl;
364 if (*inspec >= 0x80) {
365 if (utf8_fl && vms_vtf7_filenames) {
366 unsigned long ucs_char;
370 if ((*inspec & 0xE0) == 0xC0) {
372 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
373 if (ucs_char >= 0x80) {
374 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
377 } else if ((*inspec & 0xF0) == 0xE0) {
379 ucs_char = ((inspec[0] & 0xF) << 12) +
380 ((inspec[1] & 0x3f) << 6) +
382 if (ucs_char >= 0x800) {
383 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
387 #if 0 /* I do not see longer sequences supported by OpenVMS */
388 /* Maybe some one can fix this later */
389 } else if ((*inspec & 0xF8) == 0xF0) {
392 } else if ((*inspec & 0xFC) == 0xF8) {
395 } else if ((*inspec & 0xFE) == 0xFC) {
402 /* High bit set, but not a Unicode character! */
404 /* Non printing DECMCS or ISO Latin-1 character? */
405 if ((unsigned char)*inspec <= 0x9F) {
409 hex = (*inspec >> 4) & 0xF;
411 outspec[1] = hex + '0';
413 outspec[1] = (hex - 9) + 'A';
417 outspec[2] = hex + '0';
419 outspec[2] = (hex - 9) + 'A';
423 } else if ((unsigned char)*inspec == 0xA0) {
429 } else if ((unsigned char)*inspec == 0xFF) {
441 /* Is this a macro that needs to be passed through?
442 * Macros start with $( and an alpha character, followed
443 * by a string of alpha numeric characters ending with a )
444 * If this does not match, then encode it as ODS-5.
446 if ((inspec[0] == '$') && (inspec[1] == '(')) {
449 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
451 outspec[0] = inspec[0];
452 outspec[1] = inspec[1];
453 outspec[2] = inspec[2];
455 while(isalnum(inspec[tcnt]) ||
456 (inspec[2] == '.') || (inspec[2] == '_')) {
457 outspec[tcnt] = inspec[tcnt];
460 if (inspec[tcnt] == ')') {
461 outspec[tcnt] = inspec[tcnt];
478 if (decc_efs_charset == 0)
505 /* Don't escape again if following character is
506 * already something we escape.
508 if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
514 /* But otherwise fall through and escape it. */
516 /* Assume that this is to be escaped */
518 outspec[1] = *inspec;
522 case ' ': /* space */
523 /* Assume that this is to be escaped */
539 /* This handles the expansion of a '^' prefix to the proper character
540 * in a UNIX file specification.
542 * The output count variable contains the number of characters added
543 * to the output string.
545 * The return value is the number of characters read from the input
549 copy_expand_vms_filename_escape(char *outspec, const char *inspec, int *output_cnt)
556 if (*inspec == '^') {
559 /* Spaces and non-trailing dots should just be passed through,
560 * but eat the escape character.
567 case '_': /* space */
573 /* Hmm. Better leave the escape escaped. */
579 case 'U': /* Unicode - FIX-ME this is wrong. */
582 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
585 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
586 outspec[0] = c1 & 0xff;
587 outspec[1] = c2 & 0xff;
594 /* Error - do best we can to continue */
604 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
608 scnt = sscanf(inspec, "%2x", &c1);
609 outspec[0] = c1 & 0xff;
630 /* vms_split_path - Verify that the input file specification is a
631 * VMS format file specification, and provide pointers to the components of
632 * it. With EFS format filenames, this is virtually the only way to
633 * parse a VMS path specification into components.
635 * If the sum of the components do not add up to the length of the
636 * string, then the passed file specification is probably a UNIX style
640 vms_split_path(const char * path, char * * volume, int * vol_len, char * * root, int * root_len,
641 char * * dir, int * dir_len, char * * name, int * name_len,
642 char * * ext, int * ext_len, char * * version, int * ver_len)
644 struct dsc$descriptor path_desc;
648 struct filescan_itmlst_2 item_list[9];
649 const int filespec = 0;
650 const int nodespec = 1;
651 const int devspec = 2;
652 const int rootspec = 3;
653 const int dirspec = 4;
654 const int namespec = 5;
655 const int typespec = 6;
656 const int verspec = 7;
658 /* Assume the worst for an easy exit */
672 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
673 path_desc.dsc$w_length = strlen(path);
674 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
675 path_desc.dsc$b_class = DSC$K_CLASS_S;
677 /* Get the total length, if it is shorter than the string passed
678 * then this was probably not a VMS formatted file specification
680 item_list[filespec].itmcode = FSCN$_FILESPEC;
681 item_list[filespec].length = 0;
682 item_list[filespec].component = NULL;
684 /* If the node is present, then it gets considered as part of the
685 * volume name to hopefully make things simple.
687 item_list[nodespec].itmcode = FSCN$_NODE;
688 item_list[nodespec].length = 0;
689 item_list[nodespec].component = NULL;
691 item_list[devspec].itmcode = FSCN$_DEVICE;
692 item_list[devspec].length = 0;
693 item_list[devspec].component = NULL;
695 /* root is a special case, adding it to either the directory or
696 * the device components will probably complicate things for the
697 * callers of this routine, so leave it separate.
699 item_list[rootspec].itmcode = FSCN$_ROOT;
700 item_list[rootspec].length = 0;
701 item_list[rootspec].component = NULL;
703 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
704 item_list[dirspec].length = 0;
705 item_list[dirspec].component = NULL;
707 item_list[namespec].itmcode = FSCN$_NAME;
708 item_list[namespec].length = 0;
709 item_list[namespec].component = NULL;
711 item_list[typespec].itmcode = FSCN$_TYPE;
712 item_list[typespec].length = 0;
713 item_list[typespec].component = NULL;
715 item_list[verspec].itmcode = FSCN$_VERSION;
716 item_list[verspec].length = 0;
717 item_list[verspec].component = NULL;
719 item_list[8].itmcode = 0;
720 item_list[8].length = 0;
721 item_list[8].component = NULL;
723 status = sys$filescan
724 ((const struct dsc$descriptor_s *)&path_desc, item_list,
726 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
728 /* If we parsed it successfully these two lengths should be the same */
729 if (path_desc.dsc$w_length != item_list[filespec].length)
732 /* If we got here, then it is a VMS file specification */
735 /* set the volume name */
736 if (item_list[nodespec].length > 0) {
737 *volume = item_list[nodespec].component;
738 *vol_len = item_list[nodespec].length + item_list[devspec].length;
741 *volume = item_list[devspec].component;
742 *vol_len = item_list[devspec].length;
745 *root = item_list[rootspec].component;
746 *root_len = item_list[rootspec].length;
748 *dir = item_list[dirspec].component;
749 *dir_len = item_list[dirspec].length;
751 /* Now fun with versions and EFS file specifications
752 * The parser can not tell the difference when a "." is a version
753 * delimiter or a part of the file specification.
755 if ((decc_efs_charset) &&
756 (item_list[verspec].length > 0) &&
757 (item_list[verspec].component[0] == '.')) {
758 *name = item_list[namespec].component;
759 *name_len = item_list[namespec].length + item_list[typespec].length;
760 *ext = item_list[verspec].component;
761 *ext_len = item_list[verspec].length;
766 *name = item_list[namespec].component;
767 *name_len = item_list[namespec].length;
768 *ext = item_list[typespec].component;
769 *ext_len = item_list[typespec].length;
770 *version = item_list[verspec].component;
771 *ver_len = item_list[verspec].length;
776 /* Routine to determine if the file specification ends with .dir */
778 is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len)
781 /* e_len must be 4, and version must be <= 2 characters */
782 if (e_len != 4 || vs_len > 2)
785 /* If a version number is present, it needs to be one */
786 if ((vs_len == 2) && (vs_spec[1] != '1'))
789 /* Look for the DIR on the extension */
790 if (vms_process_case_tolerant) {
791 if ((toupper(e_spec[1]) == 'D') &&
792 (toupper(e_spec[2]) == 'I') &&
793 (toupper(e_spec[3]) == 'R')) {
797 /* Directory extensions are supposed to be in upper case only */
798 /* I would not be surprised if this rule can not be enforced */
799 /* if and when someone fully debugs the case sensitive mode */
800 if ((e_spec[1] == 'D') &&
801 (e_spec[2] == 'I') &&
802 (e_spec[3] == 'R')) {
811 * Routine to retrieve the maximum equivalence index for an input
812 * logical name. Some calls to this routine have no knowledge if
813 * the variable is a logical or not. So on error we return a max
816 /*{{{int my_maxidx(const char *lnm) */
818 my_maxidx(const char *lnm)
822 int attr = LNM$M_CASE_BLIND;
823 struct dsc$descriptor lnmdsc;
824 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
827 lnmdsc.dsc$w_length = strlen(lnm);
828 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
829 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
830 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
832 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
833 if ((status & 1) == 0)
840 /* Routine to remove the 2-byte prefix from the translation of a
841 * process-permanent file (PPF).
843 static inline unsigned short int
844 S_remove_ppf_prefix(const char *lnm, char *eqv, unsigned short int eqvlen)
846 if (*((int *)lnm) == *((int *)"SYS$") &&
847 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
848 ( (lnm[4] == 'O' && !strcmp(lnm,"SYS$OUTPUT")) ||
849 (lnm[4] == 'I' && !strcmp(lnm,"SYS$INPUT")) ||
850 (lnm[4] == 'E' && !strcmp(lnm,"SYS$ERROR")) ||
851 (lnm[4] == 'C' && !strcmp(lnm,"SYS$COMMAND")) ) ) {
853 memmove(eqv, eqv+4, eqvlen-4);
859 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
861 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
862 struct dsc$descriptor_s **tabvec, unsigned long int flags)
865 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
866 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
867 bool found_in_crtlenv = 0, found_in_clisym = 0;
868 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
870 unsigned char acmode;
871 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
872 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
873 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
874 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
876 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
877 #if defined(PERL_IMPLICIT_CONTEXT)
880 aTHX = PERL_GET_INTERP;
886 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
887 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
889 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
890 *cp2 = _toupper(*cp1);
891 if (cp1 - lnm > LNM$C_NAMLENGTH) {
892 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
896 lnmdsc.dsc$w_length = cp1 - lnm;
897 lnmdsc.dsc$a_pointer = uplnm;
898 uplnm[lnmdsc.dsc$w_length] = '\0';
899 secure = flags & PERL__TRNENV_SECURE;
900 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
901 if (!tabvec || !*tabvec) tabvec = env_tables;
903 for (curtab = 0; tabvec[curtab]; curtab++) {
904 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
905 if (!ivenv && !secure) {
910 #if defined(PERL_IMPLICIT_CONTEXT)
913 "Can't read CRTL environ\n");
916 Perl_warn(aTHX_ "Can't read CRTL environ\n");
919 retsts = SS$_NOLOGNAM;
920 for (i = 0; environ[i]; i++) {
921 if ((eq = strchr(environ[i],'=')) &&
922 lnmdsc.dsc$w_length == (eq - environ[i]) &&
923 !strncmp(environ[i],lnm,eq - environ[i])) {
925 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
926 if (!eqvlen) continue;
931 if (retsts != SS$_NOLOGNAM) {
932 found_in_crtlenv = 1;
937 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
938 !str$case_blind_compare(&tmpdsc,&clisym)) {
939 if (!ivsym && !secure) {
940 unsigned short int deflen = LNM$C_NAMLENGTH;
941 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
942 /* dynamic dsc to accommodate possible long value */
943 _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
944 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
946 if (eqvlen > MAX_DCL_SYMBOL) {
947 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
948 eqvlen = MAX_DCL_SYMBOL;
949 /* Special hack--we might be called before the interpreter's */
950 /* fully initialized, in which case either thr or PL_curcop */
951 /* might be bogus. We have to check, since ckWARN needs them */
952 /* both to be valid if running threaded */
953 #if defined(PERL_IMPLICIT_CONTEXT)
956 "Value of CLI symbol \"%s\" too long",lnm);
959 if (ckWARN(WARN_MISC)) {
960 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
963 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
965 _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
966 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
967 if (retsts == LIB$_NOSUCHSYM) continue;
973 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
974 midx = my_maxidx(lnm);
975 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
976 lnmlst[1].bufadr = cp2;
978 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
979 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
980 if (retsts == SS$_NOLOGNAM) break;
981 eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
985 if ((retsts == SS$_IVLOGNAM) ||
986 (retsts == SS$_NOLOGNAM)) { continue; }
987 eqvlen = strlen(eqv);
990 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
991 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
992 if (retsts == SS$_NOLOGNAM) continue;
993 eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
999 /* An index only makes sense for logical names, so make sure we aren't
1000 * iterating over an index for an environ var or DCL symbol and getting
1001 * the same answer ad infinitum.
1003 if (idx > 0 && (found_in_crtlenv || found_in_clisym)) {
1006 else if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1007 else if (retsts == LIB$_NOSUCHSYM ||
1008 retsts == SS$_NOLOGNAM) {
1009 /* Unsuccessful lookup is normal -- no need to set errno */
1012 else if (retsts == LIB$_INVSYMNAM ||
1013 retsts == SS$_IVLOGNAM ||
1014 retsts == SS$_IVLOGTAB) {
1015 set_errno(EINVAL); set_vaxc_errno(retsts);
1017 else _ckvmssts_noperl(retsts);
1019 } /* end of vmstrnenv */
1022 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1023 /* Define as a function so we can access statics. */
1025 Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1029 #if defined(PERL_IMPLICIT_CONTEXT)
1032 #ifdef SECURE_INTERNAL_GETENV
1033 flags = (PL_curinterp ? TAINTING_get : will_taint) ?
1034 PERL__TRNENV_SECURE : 0;
1037 return vmstrnenv(lnm, eqv, idx, fildev, flags);
1042 * Note: Uses Perl temp to store result so char * can be returned to
1043 * caller; this pointer will be invalidated at next Perl statement
1045 * We define this as a function rather than a macro in terms of my_getenv_len()
1046 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1049 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1051 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1054 static char *__my_getenv_eqv = NULL;
1055 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1056 unsigned long int idx = 0;
1057 int success, secure;
1061 midx = my_maxidx(lnm) + 1;
1063 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1064 /* Set up a temporary buffer for the return value; Perl will
1065 * clean it up at the next statement transition */
1066 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1067 if (!tmpsv) return NULL;
1071 /* Assume no interpreter ==> single thread */
1072 if (__my_getenv_eqv != NULL) {
1073 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1076 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1078 eqv = __my_getenv_eqv;
1081 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1082 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1084 getcwd(eqv,LNM$C_NAMLENGTH);
1088 /* Get rid of "000000/ in rooted filespecs */
1091 zeros = strstr(eqv, "/000000/");
1092 if (zeros != NULL) {
1094 mlen = len - (zeros - eqv) - 7;
1095 memmove(zeros, &zeros[7], mlen);
1103 /* Impose security constraints only if tainting */
1105 /* Impose security constraints only if tainting */
1106 secure = PL_curinterp ? TAINTING_get : will_taint;
1113 #ifdef SECURE_INTERNAL_GETENV
1114 secure ? PERL__TRNENV_SECURE : 0
1120 /* For the getenv interface we combine all the equivalence names
1121 * of a search list logical into one value to acquire a maximum
1122 * value length of 255*128 (assuming %ENV is using logicals).
1124 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1126 /* If the name contains a semicolon-delimited index, parse it
1127 * off and make sure we only retrieve the equivalence name for
1129 if ((cp2 = strchr(lnm,';')) != NULL) {
1130 my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1131 idx = strtoul(cp2+1,NULL,0);
1133 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1136 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1138 return success ? eqv : NULL;
1141 } /* end of my_getenv() */
1145 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1147 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1151 unsigned long idx = 0;
1153 static char *__my_getenv_len_eqv = NULL;
1157 midx = my_maxidx(lnm) + 1;
1159 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1160 /* Set up a temporary buffer for the return value; Perl will
1161 * clean it up at the next statement transition */
1162 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1163 if (!tmpsv) return NULL;
1167 /* Assume no interpreter ==> single thread */
1168 if (__my_getenv_len_eqv != NULL) {
1169 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1172 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1174 buf = __my_getenv_len_eqv;
1177 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1178 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1181 getcwd(buf,LNM$C_NAMLENGTH);
1184 /* Get rid of "000000/ in rooted filespecs */
1186 zeros = strstr(buf, "/000000/");
1187 if (zeros != NULL) {
1189 mlen = *len - (zeros - buf) - 7;
1190 memmove(zeros, &zeros[7], mlen);
1199 /* Impose security constraints only if tainting */
1200 secure = PL_curinterp ? TAINTING_get : will_taint;
1207 #ifdef SECURE_INTERNAL_GETENV
1208 secure ? PERL__TRNENV_SECURE : 0
1214 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1216 if ((cp2 = strchr(lnm,';')) != NULL) {
1217 my_strlcpy(buf, lnm, cp2 - lnm + 1);
1218 idx = strtoul(cp2+1,NULL,0);
1220 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1223 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1225 /* Get rid of "000000/ in rooted filespecs */
1228 zeros = strstr(buf, "/000000/");
1229 if (zeros != NULL) {
1231 mlen = *len - (zeros - buf) - 7;
1232 memmove(zeros, &zeros[7], mlen);
1238 return *len ? buf : NULL;
1241 } /* end of my_getenv_len() */
1244 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1246 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1248 /*{{{ void prime_env_iter() */
1250 prime_env_iter(void)
1251 /* Fill the %ENV associative array with all logical names we can
1252 * find, in preparation for iterating over it.
1255 static int primed = 0;
1256 HV *seenhv = NULL, *envhv;
1258 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1259 unsigned short int chan;
1260 #ifndef CLI$M_TRUSTED
1261 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1263 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1264 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1266 bool have_sym = FALSE, have_lnm = FALSE;
1267 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1268 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1269 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1270 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1271 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1272 #if defined(PERL_IMPLICIT_CONTEXT)
1275 #if defined(USE_ITHREADS)
1276 static perl_mutex primenv_mutex;
1277 MUTEX_INIT(&primenv_mutex);
1280 #if defined(PERL_IMPLICIT_CONTEXT)
1281 /* We jump through these hoops because we can be called at */
1282 /* platform-specific initialization time, which is before anything is */
1283 /* set up--we can't even do a plain dTHX since that relies on the */
1284 /* interpreter structure to be initialized */
1286 aTHX = PERL_GET_INTERP;
1288 /* we never get here because the NULL pointer will cause the */
1289 /* several of the routines called by this routine to access violate */
1291 /* This routine is only called by hv.c/hv_iterinit which has a */
1292 /* context, so the real fix may be to pass it through instead of */
1293 /* the hoops above */
1298 if (primed || !PL_envgv) return;
1299 MUTEX_LOCK(&primenv_mutex);
1300 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1301 envhv = GvHVn(PL_envgv);
1302 /* Perform a dummy fetch as an lval to insure that the hash table is
1303 * set up. Otherwise, the hv_store() will turn into a nullop. */
1304 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1306 for (i = 0; env_tables[i]; i++) {
1307 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1308 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1309 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1311 if (have_sym || have_lnm) {
1312 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1313 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1314 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1315 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1318 for (i--; i >= 0; i--) {
1319 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1322 /* Start at the end, so if there is a duplicate we keep the first one. */
1323 for (j = 0; environ[j]; j++);
1324 for (j--; j >= 0; j--) {
1325 if (!(start = strchr(environ[j],'='))) {
1326 if (ckWARN(WARN_INTERNAL))
1327 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1331 sv = newSVpv(start,0);
1333 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1338 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1339 !str$case_blind_compare(&tmpdsc,&clisym)) {
1340 my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1341 cmddsc.dsc$w_length = 20;
1342 if (env_tables[i]->dsc$w_length == 12 &&
1343 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1344 !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local *", sizeof(cmd)-12);
1345 flags = defflags | CLI$M_NOLOGNAM;
1348 my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1349 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1350 my_strlcat(cmd," /Table=", sizeof(cmd));
1351 cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, sizeof(cmd));
1353 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1354 flags = defflags | CLI$M_NOCLISYM;
1357 /* Create a new subprocess to execute each command, to exclude the
1358 * remote possibility that someone could subvert a mbx or file used
1359 * to write multiple commands to a single subprocess.
1362 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1363 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1364 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1365 defflags &= ~CLI$M_TRUSTED;
1366 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1368 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1369 if (seenhv) SvREFCNT_dec(seenhv);
1372 char *cp1, *cp2, *key;
1373 unsigned long int sts, iosb[2], retlen, keylen;
1376 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1377 if (sts & 1) sts = iosb[0] & 0xffff;
1378 if (sts == SS$_ENDOFFILE) {
1380 while (substs == 0) { sys$hiber(); wakect++;}
1381 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1386 retlen = iosb[0] >> 16;
1387 if (!retlen) continue; /* blank line */
1389 if (iosb[1] != subpid) {
1391 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1395 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1396 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1398 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1399 if (*cp1 == '(' || /* Logical name table name */
1400 *cp1 == '=' /* Next eqv of searchlist */) continue;
1401 if (*cp1 == '"') cp1++;
1402 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1403 key = cp1; keylen = cp2 - cp1;
1404 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1405 while (*cp2 && *cp2 != '=') cp2++;
1406 while (*cp2 && *cp2 == '=') cp2++;
1407 while (*cp2 && *cp2 == ' ') cp2++;
1408 if (*cp2 == '"') { /* String translation; may embed "" */
1409 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1410 cp2++; cp1--; /* Skip "" surrounding translation */
1412 else { /* Numeric translation */
1413 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1414 cp1--; /* stop on last non-space char */
1416 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1417 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1420 PERL_HASH(hash,key,keylen);
1422 if (cp1 == cp2 && *cp2 == '.') {
1423 /* A single dot usually means an unprintable character, such as a null
1424 * to indicate a zero-length value. Get the actual value to make sure.
1426 char lnm[LNM$C_NAMLENGTH+1];
1427 char eqv[MAX_DCL_SYMBOL+1];
1429 strncpy(lnm, key, keylen);
1430 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1431 sv = newSVpvn(eqv, strlen(eqv));
1434 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1438 hv_store(envhv,key,keylen,sv,hash);
1439 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1441 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1442 /* get the PPFs for this process, not the subprocess */
1443 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1444 char eqv[LNM$C_NAMLENGTH+1];
1446 for (i = 0; ppfs[i]; i++) {
1447 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1448 sv = newSVpv(eqv,trnlen);
1450 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1455 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1456 if (buf) Safefree(buf);
1457 if (seenhv) SvREFCNT_dec(seenhv);
1458 MUTEX_UNLOCK(&primenv_mutex);
1461 } /* end of prime_env_iter */
1465 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1466 /* Define or delete an element in the same "environment" as
1467 * vmstrnenv(). If an element is to be deleted, it's removed from
1468 * the first place it's found. If it's to be set, it's set in the
1469 * place designated by the first element of the table vector.
1470 * Like setenv() returns 0 for success, non-zero on error.
1473 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1476 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1477 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1479 unsigned long int retsts, usermode = PSL$C_USER;
1480 struct itmlst_3 *ile, *ilist;
1481 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1482 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1483 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1484 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1485 $DESCRIPTOR(local,"_LOCAL");
1488 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1489 return SS$_IVLOGNAM;
1492 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1493 *cp2 = _toupper(*cp1);
1494 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1495 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1496 return SS$_IVLOGNAM;
1499 lnmdsc.dsc$w_length = cp1 - lnm;
1500 if (!tabvec || !*tabvec) tabvec = env_tables;
1502 if (!eqv) { /* we're deleting n element */
1503 for (curtab = 0; tabvec[curtab]; curtab++) {
1504 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1506 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1507 if ((cp1 = strchr(environ[i],'=')) &&
1508 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1509 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1514 ivenv = 1; retsts = SS$_NOLOGNAM;
1516 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1517 !str$case_blind_compare(&tmpdsc,&clisym)) {
1518 unsigned int symtype;
1519 if (tabvec[curtab]->dsc$w_length == 12 &&
1520 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1521 !str$case_blind_compare(&tmpdsc,&local))
1522 symtype = LIB$K_CLI_LOCAL_SYM;
1523 else symtype = LIB$K_CLI_GLOBAL_SYM;
1524 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1525 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1526 if (retsts == LIB$_NOSUCHSYM) continue;
1530 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1531 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1532 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1533 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1534 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1538 else { /* we're defining a value */
1539 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1540 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1543 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1544 eqvdsc.dsc$w_length = strlen(eqv);
1545 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1546 !str$case_blind_compare(&tmpdsc,&clisym)) {
1547 unsigned int symtype;
1548 if (tabvec[0]->dsc$w_length == 12 &&
1549 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1550 !str$case_blind_compare(&tmpdsc,&local))
1551 symtype = LIB$K_CLI_LOCAL_SYM;
1552 else symtype = LIB$K_CLI_GLOBAL_SYM;
1553 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1556 if (!*eqv) eqvdsc.dsc$w_length = 1;
1557 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1559 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1560 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1561 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1562 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1563 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1564 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1567 Newx(ilist,nseg+1,struct itmlst_3);
1570 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1573 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1575 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1576 ile->itmcode = LNM$_STRING;
1578 if ((j+1) == nseg) {
1579 ile->buflen = strlen(c);
1580 /* in case we are truncating one that's too long */
1581 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1584 ile->buflen = LNM$C_NAMLENGTH;
1588 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1592 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1597 if (!(retsts & 1)) {
1599 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1600 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1601 set_errno(EVMSERR); break;
1602 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1603 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1604 set_errno(EINVAL); break;
1606 set_errno(EACCES); break;
1611 set_vaxc_errno(retsts);
1612 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1615 /* We reset error values on success because Perl does an hv_fetch()
1616 * before each hv_store(), and if the thing we're setting didn't
1617 * previously exist, we've got a leftover error message. (Of course,
1618 * this fails in the face of
1619 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1620 * in that the error reported in $! isn't spurious,
1621 * but it's right more often than not.)
1623 set_errno(0); set_vaxc_errno(retsts);
1627 } /* end of vmssetenv() */
1630 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1631 /* This has to be a function since there's a prototype for it in proto.h */
1633 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1636 int len = strlen(lnm);
1640 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1641 if (!strcmp(uplnm,"DEFAULT")) {
1642 if (eqv && *eqv) my_chdir(eqv);
1647 (void) vmssetenv(lnm,eqv,NULL);
1651 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1653 * sets a user-mode logical in the process logical name table
1654 * used for redirection of sys$error
1657 Perl_vmssetuserlnm(const char *name, const char *eqv)
1659 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1660 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1661 unsigned long int iss, attr = LNM$M_CONFINE;
1662 unsigned char acmode = PSL$C_USER;
1663 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1665 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1666 d_name.dsc$w_length = strlen(name);
1668 lnmlst[0].buflen = strlen(eqv);
1669 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1671 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1672 if (!(iss&1)) lib$signal(iss);
1677 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1678 /* my_crypt - VMS password hashing
1679 * my_crypt() provides an interface compatible with the Unix crypt()
1680 * C library function, and uses sys$hash_password() to perform VMS
1681 * password hashing. The quadword hashed password value is returned
1682 * as a NUL-terminated 8 character string. my_crypt() does not change
1683 * the case of its string arguments; in order to match the behavior
1684 * of LOGINOUT et al., alphabetic characters in both arguments must
1685 * be upcased by the caller.
1687 * - fix me to call ACM services when available
1690 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1692 # ifndef UAI$C_PREFERRED_ALGORITHM
1693 # define UAI$C_PREFERRED_ALGORITHM 127
1695 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1696 unsigned short int salt = 0;
1697 unsigned long int sts;
1699 unsigned short int dsc$w_length;
1700 unsigned char dsc$b_type;
1701 unsigned char dsc$b_class;
1702 const char * dsc$a_pointer;
1703 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1704 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1705 struct itmlst_3 uailst[3] = {
1706 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1707 { sizeof salt, UAI$_SALT, &salt, 0},
1708 { 0, 0, NULL, NULL}};
1709 static char hash[9];
1711 usrdsc.dsc$w_length = strlen(usrname);
1712 usrdsc.dsc$a_pointer = usrname;
1713 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1715 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1719 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1724 set_vaxc_errno(sts);
1725 if (sts != RMS$_RNF) return NULL;
1728 txtdsc.dsc$w_length = strlen(textpasswd);
1729 txtdsc.dsc$a_pointer = textpasswd;
1730 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1731 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1734 return (char *) hash;
1736 } /* end of my_crypt() */
1740 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1741 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1742 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1744 /* 8.3, remove() is now broken on symbolic links */
1745 static int rms_erase(const char * vmsname);
1749 * A little hack to get around a bug in some implementation of remove()
1750 * that do not know how to delete a directory
1752 * Delete any file to which user has control access, regardless of whether
1753 * delete access is explicitly allowed.
1754 * Limitations: User must have write access to parent directory.
1755 * Does not block signals or ASTs; if interrupted in midstream
1756 * may leave file with an altered ACL.
1759 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1761 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1765 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1766 unsigned long int cxt = 0, aclsts, fndsts;
1768 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1770 unsigned char myace$b_length;
1771 unsigned char myace$b_type;
1772 unsigned short int myace$w_flags;
1773 unsigned long int myace$l_access;
1774 unsigned long int myace$l_ident;
1775 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1776 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1777 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1779 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1780 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1781 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1782 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1783 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1784 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1786 /* Expand the input spec using RMS, since the CRTL remove() and
1787 * system services won't do this by themselves, so we may miss
1788 * a file "hiding" behind a logical name or search list. */
1789 vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1790 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1792 rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1794 PerlMem_free(vmsname);
1798 /* Erase the file */
1799 rmsts = rms_erase(vmsname);
1801 /* Did it succeed */
1802 if ($VMS_STATUS_SUCCESS(rmsts)) {
1803 PerlMem_free(vmsname);
1807 /* If not, can changing protections help? */
1808 if (rmsts != RMS$_PRV) {
1809 set_vaxc_errno(rmsts);
1810 PerlMem_free(vmsname);
1814 /* No, so we get our own UIC to use as a rights identifier,
1815 * and the insert an ACE at the head of the ACL which allows us
1816 * to delete the file.
1818 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1819 fildsc.dsc$w_length = strlen(vmsname);
1820 fildsc.dsc$a_pointer = vmsname;
1822 newace.myace$l_ident = oldace.myace$l_ident;
1824 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1826 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1827 set_errno(ENOENT); break;
1829 set_errno(ENOTDIR); break;
1831 set_errno(ENODEV); break;
1832 case RMS$_SYN: case SS$_INVFILFOROP:
1833 set_errno(EINVAL); break;
1835 set_errno(EACCES); break;
1837 _ckvmssts_noperl(aclsts);
1839 set_vaxc_errno(aclsts);
1840 PerlMem_free(vmsname);
1843 /* Grab any existing ACEs with this identifier in case we fail */
1844 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1845 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1846 || fndsts == SS$_NOMOREACE ) {
1847 /* Add the new ACE . . . */
1848 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1851 rmsts = rms_erase(vmsname);
1852 if ($VMS_STATUS_SUCCESS(rmsts)) {
1857 /* We blew it - dir with files in it, no write priv for
1858 * parent directory, etc. Put things back the way they were. */
1859 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1862 addlst[0].bufadr = &oldace;
1863 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1870 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1871 /* We just deleted it, so of course it's not there. Some versions of
1872 * VMS seem to return success on the unlock operation anyhow (after all
1873 * the unlock is successful), but others don't.
1875 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1876 if (aclsts & 1) aclsts = fndsts;
1877 if (!(aclsts & 1)) {
1879 set_vaxc_errno(aclsts);
1882 PerlMem_free(vmsname);
1885 } /* end of kill_file() */
1889 /*{{{int do_rmdir(char *name)*/
1891 Perl_do_rmdir(pTHX_ const char *name)
1897 /* lstat returns a VMS fileified specification of the name */
1898 /* that is looked up, and also lets verifies that this is a directory */
1900 retval = flex_lstat(name, &st);
1904 /* Due to a historical feature, flex_stat/lstat can not see some */
1905 /* Unix format file names that the rest of the CRTL can see */
1906 /* Fixing that feature will cause some perl tests to fail */
1907 /* So try this one more time. */
1909 retval = lstat(name, &st.crtl_stat);
1913 /* force it to a file spec for the kill file to work. */
1914 ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1915 if (ret_spec == NULL) {
1921 if (!S_ISDIR(st.st_mode)) {
1926 dirfile = st.st_devnam;
1928 /* It may be possible for flex_stat to find a file and vmsify() to */
1929 /* fail with ODS-2 specifications. mp_do_kill_file can not deal */
1930 /* with that case, so fail it */
1931 if (dirfile[0] == 0) {
1936 retval = mp_do_kill_file(aTHX_ dirfile, 1);
1941 } /* end of do_rmdir */
1945 * Delete any file to which user has control access, regardless of whether
1946 * delete access is explicitly allowed.
1947 * Limitations: User must have write access to parent directory.
1948 * Does not block signals or ASTs; if interrupted in midstream
1949 * may leave file with an altered ACL.
1952 /*{{{int kill_file(char *name)*/
1954 Perl_kill_file(pTHX_ const char *name)
1960 /* Convert the filename to VMS format and see if it is a directory */
1961 /* flex_lstat returns a vmsified file specification */
1962 rmsts = flex_lstat(name, &st);
1965 /* Due to a historical feature, flex_stat/lstat can not see some */
1966 /* Unix format file names that the rest of the CRTL can see when */
1967 /* ODS-2 file specifications are in use. */
1968 /* Fixing that feature will cause some perl tests to fail */
1969 /* [.lib.ExtUtils.t]Manifest.t is one of them */
1971 vmsfile = (char *) name; /* cast ok */
1974 vmsfile = st.st_devnam;
1975 if (vmsfile[0] == 0) {
1976 /* It may be possible for flex_stat to find a file and vmsify() */
1977 /* to fail with ODS-2 specifications. mp_do_kill_file can not */
1978 /* deal with that case, so fail it */
1984 /* Remove() is allowed to delete directories, according to the X/Open
1986 * This may need special handling to work with the ACL hacks.
1988 if (S_ISDIR(st.st_mode)) {
1989 rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
1993 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
1995 /* Need to delete all versions ? */
1996 if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
1999 /* Just use lstat() here as do not need st_dev */
2000 /* and we know that the file is in VMS format or that */
2001 /* because of a historical bug, flex_stat can not see the file */
2002 while (lstat(vmsfile, (stat_t *)&st) == 0) {
2003 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2008 /* Make sure that we do not loop forever */
2019 } /* end of kill_file() */
2023 /*{{{int my_mkdir(char *,Mode_t)*/
2025 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2027 STRLEN dirlen = strlen(dir);
2029 /* zero length string sometimes gives ACCVIO */
2030 if (dirlen == 0) return -1;
2032 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2033 * null file name/type. However, it's commonplace under Unix,
2034 * so we'll allow it for a gain in portability.
2036 if (dir[dirlen-1] == '/') {
2037 char *newdir = savepvn(dir,dirlen-1);
2038 int ret = mkdir(newdir,mode);
2042 else return mkdir(dir,mode);
2043 } /* end of my_mkdir */
2046 /*{{{int my_chdir(char *)*/
2048 Perl_my_chdir(pTHX_ const char *dir)
2050 STRLEN dirlen = strlen(dir);
2051 const char *dir1 = dir;
2053 /* POSIX says we should set ENOENT for zero length string. */
2055 SETERRNO(ENOENT, RMS$_DNF);
2059 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2060 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2061 * so that existing scripts do not need to be changed.
2063 while ((dirlen > 0) && (*dir1 == ' ')) {
2068 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2070 * null file name/type. However, it's commonplace under Unix,
2071 * so we'll allow it for a gain in portability.
2073 * '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2075 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2078 newdir = (char *)PerlMem_malloc(dirlen);
2080 _ckvmssts_noperl(SS$_INSFMEM);
2081 memcpy(newdir, dir1, dirlen-1);
2082 newdir[dirlen-1] = '\0';
2083 ret = chdir(newdir);
2084 PerlMem_free(newdir);
2087 else return chdir(dir1);
2088 } /* end of my_chdir */
2092 /*{{{int my_chmod(char *, mode_t)*/
2094 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2099 STRLEN speclen = strlen(file_spec);
2101 /* zero length string sometimes gives ACCVIO */
2102 if (speclen == 0) return -1;
2104 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2105 * that implies null file name/type. However, it's commonplace under Unix,
2106 * so we'll allow it for a gain in portability.
2108 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2109 * in VMS file.dir notation.
2111 changefile = (char *) file_spec; /* cast ok */
2112 ret = flex_lstat(file_spec, &st);
2115 /* Due to a historical feature, flex_stat/lstat can not see some */
2116 /* Unix format file names that the rest of the CRTL can see when */
2117 /* ODS-2 file specifications are in use. */
2118 /* Fixing that feature will cause some perl tests to fail */
2119 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2123 /* It may be possible to get here with nothing in st_devname */
2124 /* chmod still may work though */
2125 if (st.st_devnam[0] != 0) {
2126 changefile = st.st_devnam;
2129 ret = chmod(changefile, mode);
2131 } /* end of my_chmod */
2135 /*{{{FILE *my_tmpfile()*/
2142 if ((fp = tmpfile())) return fp;
2144 cp = (char *)PerlMem_malloc(L_tmpnam+24);
2145 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2147 if (decc_filename_unix_only == 0)
2148 strcpy(cp,"Sys$Scratch:");
2151 tmpnam(cp+strlen(cp));
2152 strcat(cp,".Perltmp");
2153 fp = fopen(cp,"w+","fop=dlt");
2161 * The C RTL's sigaction fails to check for invalid signal numbers so we
2162 * help it out a bit. The docs are correct, but the actual routine doesn't
2163 * do what the docs say it will.
2165 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2167 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2168 struct sigaction* oact)
2170 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2171 SETERRNO(EINVAL, SS$_INVARG);
2174 return sigaction(sig, act, oact);
2178 #include <errnodef.h>
2180 /* We implement our own kill() using the undocumented system service
2181 sys$sigprc for one of two reasons:
2183 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2184 target process to do a sys$exit, which usually can't be handled
2185 gracefully...certainly not by Perl and the %SIG{} mechanism.
2187 2.) If the kill() in the CRTL can't be called from a signal
2188 handler without disappearing into the ether, i.e., the signal
2189 it purportedly sends is never trapped. Still true as of VMS 7.3.
2191 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2192 in the target process rather than calling sys$exit.
2194 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2195 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2196 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2197 with condition codes C$_SIG0+nsig*8, catching the exception on the
2198 target process and resignaling with appropriate arguments.
2200 But we don't have that VMS 7.0+ exception handler, so if you
2201 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2203 Also note that SIGTERM is listed in the docs as being "unimplemented",
2204 yet always seems to be signaled with a VMS condition code of 4 (and
2205 correctly handled for that code). So we hardwire it in.
2207 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2208 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2209 than signalling with an unrecognized (and unhandled by CRTL) code.
2212 #define _MY_SIG_MAX 28
2215 Perl_sig_to_vmscondition_int(int sig)
2217 static unsigned int sig_code[_MY_SIG_MAX+1] =
2220 SS$_HANGUP, /* 1 SIGHUP */
2221 SS$_CONTROLC, /* 2 SIGINT */
2222 SS$_CONTROLY, /* 3 SIGQUIT */
2223 SS$_RADRMOD, /* 4 SIGILL */
2224 SS$_BREAK, /* 5 SIGTRAP */
2225 SS$_OPCCUS, /* 6 SIGABRT */
2226 SS$_COMPAT, /* 7 SIGEMT */
2227 SS$_HPARITH, /* 8 SIGFPE AXP */
2228 SS$_ABORT, /* 9 SIGKILL */
2229 SS$_ACCVIO, /* 10 SIGBUS */
2230 SS$_ACCVIO, /* 11 SIGSEGV */
2231 SS$_BADPARAM, /* 12 SIGSYS */
2232 SS$_NOMBX, /* 13 SIGPIPE */
2233 SS$_ASTFLT, /* 14 SIGALRM */
2250 static int initted = 0;
2253 sig_code[16] = C$_SIGUSR1;
2254 sig_code[17] = C$_SIGUSR2;
2255 sig_code[20] = C$_SIGCHLD;
2256 sig_code[28] = C$_SIGWINCH;
2259 if (sig < _SIG_MIN) return 0;
2260 if (sig > _MY_SIG_MAX) return 0;
2261 return sig_code[sig];
2265 Perl_sig_to_vmscondition(int sig)
2268 if (vms_debug_on_exception != 0)
2269 lib$signal(SS$_DEBUG);
2271 return Perl_sig_to_vmscondition_int(sig);
2275 #ifdef KILL_BY_SIGPRC
2276 #define sys$sigprc SYS$SIGPRC
2280 int sys$sigprc(unsigned int *pidadr,
2281 struct dsc$descriptor_s *prcname,
2288 Perl_my_kill(int pid, int sig)
2293 /* sig 0 means validate the PID */
2294 /*------------------------------*/
2296 const unsigned long int jpicode = JPI$_PID;
2299 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2300 if ($VMS_STATUS_SUCCESS(status))
2303 case SS$_NOSUCHNODE:
2304 case SS$_UNREACHABLE:
2318 code = Perl_sig_to_vmscondition_int(sig);
2321 SETERRNO(EINVAL, SS$_BADPARAM);
2325 /* Per official UNIX specification: If pid = 0, or negative then
2326 * signals are to be sent to multiple processes.
2327 * pid = 0 - all processes in group except ones that the system exempts
2328 * pid = -1 - all processes except ones that the system exempts
2329 * pid = -n - all processes in group (abs(n)) except ...
2331 * Handle these via killpg, which is redundant for the -n case, since OP_KILL
2332 * in doio.c already does that. killpg currently does not support the -1 case.
2336 return killpg(-pid, sig);
2339 iss = sys$sigprc((unsigned int *)&pid,0,code);
2340 if (iss&1) return 0;
2344 set_errno(EPERM); break;
2346 case SS$_NOSUCHNODE:
2347 case SS$_UNREACHABLE:
2348 set_errno(ESRCH); break;
2350 set_errno(ENOMEM); break;
2352 _ckvmssts_noperl(iss);
2355 set_vaxc_errno(iss);
2362 Perl_my_killpg(pid_t master_pid, int signum)
2365 unsigned long int jpi_context;
2366 unsigned short int iosb[4];
2367 struct itmlst_3 il3[3];
2369 /* All processes on the system? Seems dangerous, but it looks
2370 * like we could implement this pretty easily with a wildcard
2371 * input to sys$process_scan.
2373 if (master_pid == -1) {
2374 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2378 /* All processes in the current process group; find the master
2379 * pid for the current process.
2381 if (master_pid == 0) {
2383 il3[i].buflen = sizeof( int );
2384 il3[i].itmcode = JPI$_MASTER_PID;
2385 il3[i].bufadr = &master_pid;
2386 il3[i++].retlen = NULL;
2390 il3[i].bufadr = NULL;
2391 il3[i++].retlen = NULL;
2393 status = sys$getjpiw(EFN$C_ENF, NULL, NULL, il3, iosb, NULL, 0);
2394 if ($VMS_STATUS_SUCCESS(status))
2402 SETERRNO(EPERM, status);
2404 case SS$_NOMOREPROC:
2406 case SS$_NOSUCHNODE:
2407 case SS$_UNREACHABLE:
2408 SETERRNO(ESRCH, status);
2412 SETERRNO(EINVAL, status);
2415 SETERRNO(EVMSERR, status);
2417 if (!$VMS_STATUS_SUCCESS(status))
2421 /* Set up a process context for those processes we will scan
2422 * with sys$getjpiw. Ask for all processes belonging to the
2428 il3[i].itmcode = PSCAN$_MASTER_PID;
2429 il3[i].bufadr = (void *)master_pid;
2430 il3[i++].retlen = NULL;
2434 il3[i].bufadr = NULL;
2435 il3[i++].retlen = NULL;
2437 status = sys$process_scan(&jpi_context, il3);
2445 SETERRNO(EINVAL, status);
2448 SETERRNO(EVMSERR, status);
2450 if (!$VMS_STATUS_SUCCESS(status))
2454 il3[i].buflen = sizeof(int);
2455 il3[i].itmcode = JPI$_PID;
2456 il3[i].bufadr = &pid;
2457 il3[i++].retlen = NULL;
2461 il3[i].bufadr = NULL;
2462 il3[i++].retlen = NULL;
2464 /* Loop through the processes matching our specified criteria
2468 /* Find the next process...
2470 status = sys$getjpiw( EFN$C_ENF, &jpi_context, NULL, il3, iosb, NULL, 0);
2471 if ($VMS_STATUS_SUCCESS(status)) status = iosb[0];
2475 if (kill(pid, signum) == -1)
2478 continue; /* next process */
2481 SETERRNO(EPERM, status);
2483 case SS$_NOMOREPROC:
2486 case SS$_NOSUCHNODE:
2487 case SS$_UNREACHABLE:
2488 SETERRNO(ESRCH, status);
2492 SETERRNO(EINVAL, status);
2495 SETERRNO(EVMSERR, status);
2498 if (!$VMS_STATUS_SUCCESS(status))
2502 /* Release context-related resources.
2504 (void) sys$process_scan(&jpi_context);
2506 if (status != SS$_NOMOREPROC)
2512 /* Routine to convert a VMS status code to a UNIX status code.
2513 ** More tricky than it appears because of conflicting conventions with
2516 ** VMS status codes are a bit mask, with the least significant bit set for
2519 ** Special UNIX status of EVMSERR indicates that no translation is currently
2520 ** available, and programs should check the VMS status code.
2522 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2526 #ifndef C_FACILITY_NO
2527 #define C_FACILITY_NO 0x350000
2530 #define DCL_IVVERB 0x38090
2534 Perl_vms_status_to_unix(int vms_status, int child_flag)
2542 /* Assume the best or the worst */
2543 if (vms_status & STS$M_SUCCESS)
2546 unix_status = EVMSERR;
2548 msg_status = vms_status & ~STS$M_CONTROL;
2550 facility = vms_status & STS$M_FAC_NO;
2551 fac_sp = vms_status & STS$M_FAC_SP;
2552 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2554 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2560 unix_status = EFAULT;
2562 case SS$_DEVOFFLINE:
2563 unix_status = EBUSY;
2566 unix_status = ENOTCONN;
2574 case SS$_INVFILFOROP:
2578 unix_status = EINVAL;
2580 case SS$_UNSUPPORTED:
2581 unix_status = ENOTSUP;
2586 unix_status = EACCES;
2588 case SS$_DEVICEFULL:
2589 unix_status = ENOSPC;
2592 unix_status = ENODEV;
2594 case SS$_NOSUCHFILE:
2595 case SS$_NOSUCHOBJECT:
2596 unix_status = ENOENT;
2598 case SS$_ABORT: /* Fatal case */
2599 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2600 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2601 unix_status = EINTR;
2604 unix_status = E2BIG;
2607 unix_status = ENOMEM;
2610 unix_status = EPERM;
2612 case SS$_NOSUCHNODE:
2613 case SS$_UNREACHABLE:
2614 unix_status = ESRCH;
2617 unix_status = ECHILD;
2620 if ((facility == 0) && (msg_no < 8)) {
2621 /* These are not real VMS status codes so assume that they are
2622 ** already UNIX status codes
2624 unix_status = msg_no;
2630 /* Translate a POSIX exit code to a UNIX exit code */
2631 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2632 unix_status = (msg_no & 0x07F8) >> 3;
2636 /* Documented traditional behavior for handling VMS child exits */
2637 /*--------------------------------------------------------------*/
2638 if (child_flag != 0) {
2640 /* Success / Informational return 0 */
2641 /*----------------------------------*/
2642 if (msg_no & STS$K_SUCCESS)
2645 /* Warning returns 1 */
2646 /*-------------------*/
2647 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2650 /* Everything else pass through the severity bits */
2651 /*------------------------------------------------*/
2652 return (msg_no & STS$M_SEVERITY);
2655 /* Normal VMS status to ERRNO mapping attempt */
2656 /*--------------------------------------------*/
2657 switch(msg_status) {
2658 /* case RMS$_EOF: */ /* End of File */
2659 case RMS$_FNF: /* File Not Found */
2660 case RMS$_DNF: /* Dir Not Found */
2661 unix_status = ENOENT;
2663 case RMS$_RNF: /* Record Not Found */
2664 unix_status = ESRCH;
2667 unix_status = ENOTDIR;
2670 unix_status = ENODEV;
2675 unix_status = EBADF;
2678 unix_status = EEXIST;
2682 case LIB$_INVSTRDES:
2684 case LIB$_NOSUCHSYM:
2685 case LIB$_INVSYMNAM:
2687 unix_status = EINVAL;
2693 unix_status = E2BIG;
2695 case RMS$_PRV: /* No privilege */
2696 case RMS$_ACC: /* ACP file access failed */
2697 case RMS$_WLK: /* Device write locked */
2698 unix_status = EACCES;
2700 case RMS$_MKD: /* Failed to mark for delete */
2701 unix_status = EPERM;
2703 /* case RMS$_NMF: */ /* No more files */
2711 /* Try to guess at what VMS error status should go with a UNIX errno
2712 * value. This is hard to do as there could be many possible VMS
2713 * error statuses that caused the errno value to be set.
2717 Perl_unix_status_to_vms(int unix_status)
2719 int test_unix_status;
2721 /* Trivial cases first */
2722 /*---------------------*/
2723 if (unix_status == EVMSERR)
2726 /* Is vaxc$errno sane? */
2727 /*---------------------*/
2728 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2729 if (test_unix_status == unix_status)
2732 /* If way out of range, must be VMS code already */
2733 /*-----------------------------------------------*/
2734 if (unix_status > EVMSERR)
2737 /* If out of range, punt */
2738 /*-----------------------*/
2739 if (unix_status > __ERRNO_MAX)
2743 /* Ok, now we have to do it the hard way. */
2744 /*----------------------------------------*/
2745 switch(unix_status) {
2746 case 0: return SS$_NORMAL;
2747 case EPERM: return SS$_NOPRIV;
2748 case ENOENT: return SS$_NOSUCHOBJECT;
2749 case ESRCH: return SS$_UNREACHABLE;
2750 case EINTR: return SS$_ABORT;
2753 case E2BIG: return SS$_BUFFEROVF;
2755 case EBADF: return RMS$_IFI;
2756 case ECHILD: return SS$_NONEXPR;
2758 case ENOMEM: return SS$_INSFMEM;
2759 case EACCES: return SS$_FILACCERR;
2760 case EFAULT: return SS$_ACCVIO;
2762 case EBUSY: return SS$_DEVOFFLINE;
2763 case EEXIST: return RMS$_FEX;
2765 case ENODEV: return SS$_NOSUCHDEV;
2766 case ENOTDIR: return RMS$_DIR;
2768 case EINVAL: return SS$_INVARG;
2774 case ENOSPC: return SS$_DEVICEFULL;
2775 case ESPIPE: return LIB$_INVARG;
2780 case ERANGE: return LIB$_INVARG;
2781 /* case EWOULDBLOCK */
2782 /* case EINPROGRESS */
2785 /* case EDESTADDRREQ */
2787 /* case EPROTOTYPE */
2788 /* case ENOPROTOOPT */
2789 /* case EPROTONOSUPPORT */
2790 /* case ESOCKTNOSUPPORT */
2791 /* case EOPNOTSUPP */
2792 /* case EPFNOSUPPORT */
2793 /* case EAFNOSUPPORT */
2794 /* case EADDRINUSE */
2795 /* case EADDRNOTAVAIL */
2797 /* case ENETUNREACH */
2798 /* case ENETRESET */
2799 /* case ECONNABORTED */
2800 /* case ECONNRESET */
2803 case ENOTCONN: return SS$_CLEARED;
2804 /* case ESHUTDOWN */
2805 /* case ETOOMANYREFS */
2806 /* case ETIMEDOUT */
2807 /* case ECONNREFUSED */
2809 /* case ENAMETOOLONG */
2810 /* case EHOSTDOWN */
2811 /* case EHOSTUNREACH */
2812 /* case ENOTEMPTY */
2824 /* case ECANCELED */
2828 return SS$_UNSUPPORTED;
2834 /* case EABANDONED */
2836 return SS$_ABORT; /* punt */
2841 /* default piping mailbox size */
2842 #define PERL_BUFSIZ 8192
2846 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2848 unsigned long int mbxbufsiz;
2849 static unsigned long int syssize = 0;
2850 unsigned long int dviitm = DVI$_DEVNAM;
2851 char csize[LNM$C_NAMLENGTH+1];
2855 unsigned long syiitm = SYI$_MAXBUF;
2857 * Get the SYSGEN parameter MAXBUF
2859 * If the logical 'PERL_MBX_SIZE' is defined
2860 * use the value of the logical instead of PERL_BUFSIZ, but
2861 * keep the size between 128 and MAXBUF.
2864 _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2867 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2868 mbxbufsiz = atoi(csize);
2870 mbxbufsiz = PERL_BUFSIZ;
2872 if (mbxbufsiz < 128) mbxbufsiz = 128;
2873 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2875 _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2877 sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2878 _ckvmssts_noperl(sts);
2879 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2881 } /* end of create_mbx() */
2884 /*{{{ my_popen and my_pclose*/
2886 typedef struct _iosb IOSB;
2887 typedef struct _iosb* pIOSB;
2888 typedef struct _pipe Pipe;
2889 typedef struct _pipe* pPipe;
2890 typedef struct pipe_details Info;
2891 typedef struct pipe_details* pInfo;
2892 typedef struct _srqp RQE;
2893 typedef struct _srqp* pRQE;
2894 typedef struct _tochildbuf CBuf;
2895 typedef struct _tochildbuf* pCBuf;
2898 unsigned short status;
2899 unsigned short count;
2900 unsigned long dvispec;
2903 #pragma member_alignment save
2904 #pragma nomember_alignment quadword
2905 struct _srqp { /* VMS self-relative queue entry */
2906 unsigned long qptr[2];
2908 #pragma member_alignment restore
2909 static RQE RQE_ZERO = {0,0};
2911 struct _tochildbuf {
2914 unsigned short size;
2922 unsigned short chan_in;
2923 unsigned short chan_out;
2925 unsigned int bufsize;
2937 #if defined(PERL_IMPLICIT_CONTEXT)
2938 void *thx; /* Either a thread or an interpreter */
2939 /* pointer, depending on how we're built */
2947 PerlIO *fp; /* file pointer to pipe mailbox */
2948 int useFILE; /* using stdio, not perlio */
2949 int pid; /* PID of subprocess */
2950 int mode; /* == 'r' if pipe open for reading */
2951 int done; /* subprocess has completed */
2952 int waiting; /* waiting for completion/closure */
2953 int closing; /* my_pclose is closing this pipe */
2954 unsigned long completion; /* termination status of subprocess */
2955 pPipe in; /* pipe in to sub */
2956 pPipe out; /* pipe out of sub */
2957 pPipe err; /* pipe of sub's sys$error */
2958 int in_done; /* true when in pipe finished */
2961 unsigned short xchan; /* channel to debug xterm */
2962 unsigned short xchan_valid; /* channel is assigned */
2965 struct exit_control_block
2967 struct exit_control_block *flink;
2968 unsigned long int (*exit_routine)(void);
2969 unsigned long int arg_count;
2970 unsigned long int *status_address;
2971 unsigned long int exit_status;
2974 typedef struct _closed_pipes Xpipe;
2975 typedef struct _closed_pipes* pXpipe;
2977 struct _closed_pipes {
2978 int pid; /* PID of subprocess */
2979 unsigned long completion; /* termination status of subprocess */
2981 #define NKEEPCLOSED 50
2982 static Xpipe closed_list[NKEEPCLOSED];
2983 static int closed_index = 0;
2984 static int closed_num = 0;
2986 #define RETRY_DELAY "0 ::0.20"
2987 #define MAX_RETRY 50
2989 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2990 static unsigned long mypid;
2991 static unsigned long delaytime[2];
2993 static pInfo open_pipes = NULL;
2994 static $DESCRIPTOR(nl_desc, "NL:");
2996 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
3000 static unsigned long int
3001 pipe_exit_routine(void)
3004 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
3005 int sts, did_stuff, j;
3008 * Flush any pending i/o, but since we are in process run-down, be
3009 * careful about referencing PerlIO structures that may already have
3010 * been deallocated. We may not even have an interpreter anymore.
3015 #if defined(PERL_IMPLICIT_CONTEXT)
3016 /* We need to use the Perl context of the thread that created */
3020 aTHX = info->err->thx;
3022 aTHX = info->out->thx;
3024 aTHX = info->in->thx;
3027 #if defined(USE_ITHREADS)
3031 && PL_perlio_fd_refcnt
3034 PerlIO_flush(info->fp);
3036 fflush((FILE *)info->fp);
3042 next we try sending an EOF...ignore if doesn't work, make sure we
3049 _ckvmssts_noperl(sys$setast(0));
3050 if (info->in && !info->in->shut_on_empty) {
3051 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3056 _ckvmssts_noperl(sys$setast(1));
3060 /* wait for EOF to have effect, up to ~ 30 sec [default] */
3062 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3067 _ckvmssts_noperl(sys$setast(0));
3068 if (info->waiting && info->done)
3070 nwait += info->waiting;
3071 _ckvmssts_noperl(sys$setast(1));
3081 _ckvmssts_noperl(sys$setast(0));
3082 if (!info->done) { /* Tap them gently on the shoulder . . .*/
3083 sts = sys$forcex(&info->pid,0,&abort);
3084 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3087 _ckvmssts_noperl(sys$setast(1));
3091 /* again, wait for effect */
3093 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3098 _ckvmssts_noperl(sys$setast(0));
3099 if (info->waiting && info->done)
3101 nwait += info->waiting;
3102 _ckvmssts_noperl(sys$setast(1));
3111 _ckvmssts_noperl(sys$setast(0));
3112 if (!info->done) { /* We tried to be nice . . . */
3113 sts = sys$delprc(&info->pid,0);
3114 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3115 info->done = 1; /* sys$delprc is as done as we're going to get. */
3117 _ckvmssts_noperl(sys$setast(1));
3123 #if defined(PERL_IMPLICIT_CONTEXT)
3124 /* We need to use the Perl context of the thread that created */
3127 if (open_pipes->err)
3128 aTHX = open_pipes->err->thx;
3129 else if (open_pipes->out)
3130 aTHX = open_pipes->out->thx;
3131 else if (open_pipes->in)
3132 aTHX = open_pipes->in->thx;
3134 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3135 else if (!(sts & 1)) retsts = sts;
3140 static struct exit_control_block pipe_exitblock =
3141 {(struct exit_control_block *) 0,
3142 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3144 static void pipe_mbxtofd_ast(pPipe p);
3145 static void pipe_tochild1_ast(pPipe p);
3146 static void pipe_tochild2_ast(pPipe p);
3149 popen_completion_ast(pInfo info)
3151 pInfo i = open_pipes;
3154 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3155 closed_list[closed_index].pid = info->pid;
3156 closed_list[closed_index].completion = info->completion;
3158 if (closed_index == NKEEPCLOSED)
3163 if (i == info) break;
3166 if (!i) return; /* unlinked, probably freed too */
3171 Writing to subprocess ...
3172 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3174 chan_out may be waiting for "done" flag, or hung waiting
3175 for i/o completion to child...cancel the i/o. This will
3176 put it into "snarf mode" (done but no EOF yet) that discards
3179 Output from subprocess (stdout, stderr) needs to be flushed and
3180 shut down. We try sending an EOF, but if the mbx is full the pipe
3181 routine should still catch the "shut_on_empty" flag, telling it to
3182 use immediate-style reads so that "mbx empty" -> EOF.
3186 if (info->in && !info->in_done) { /* only for mode=w */
3187 if (info->in->shut_on_empty && info->in->need_wake) {
3188 info->in->need_wake = FALSE;
3189 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3191 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3195 if (info->out && !info->out_done) { /* were we also piping output? */
3196 info->out->shut_on_empty = TRUE;
3197 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3198 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3199 _ckvmssts_noperl(iss);
3202 if (info->err && !info->err_done) { /* we were piping stderr */
3203 info->err->shut_on_empty = TRUE;
3204 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3205 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3206 _ckvmssts_noperl(iss);
3208 _ckvmssts_noperl(sys$setef(pipe_ef));
3212 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3213 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3214 static void pipe_infromchild_ast(pPipe p);
3217 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3218 inside an AST routine without worrying about reentrancy and which Perl
3219 memory allocator is being used.
3221 We read data and queue up the buffers, then spit them out one at a
3222 time to the output mailbox when the output mailbox is ready for one.
3225 #define INITIAL_TOCHILDQUEUE 2
3228 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3232 char mbx1[64], mbx2[64];
3233 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3234 DSC$K_CLASS_S, mbx1},
3235 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3236 DSC$K_CLASS_S, mbx2};
3237 unsigned int dviitm = DVI$_DEVBUFSIZ;
3241 _ckvmssts_noperl(lib$get_vm(&n, &p));
3243 create_mbx(&p->chan_in , &d_mbx1);
3244 create_mbx(&p->chan_out, &d_mbx2);
3245 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3248 p->shut_on_empty = FALSE;
3249 p->need_wake = FALSE;
3252 p->iosb.status = SS$_NORMAL;
3253 p->iosb2.status = SS$_NORMAL;
3259 #ifdef PERL_IMPLICIT_CONTEXT
3263 n = sizeof(CBuf) + p->bufsize;
3265 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3266 _ckvmssts_noperl(lib$get_vm(&n, &b));
3267 b->buf = (char *) b + sizeof(CBuf);
3268 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3271 pipe_tochild2_ast(p);
3272 pipe_tochild1_ast(p);
3278 /* reads the MBX Perl is writing, and queues */
3281 pipe_tochild1_ast(pPipe p)
3284 int iss = p->iosb.status;
3285 int eof = (iss == SS$_ENDOFFILE);
3287 #ifdef PERL_IMPLICIT_CONTEXT
3293 p->shut_on_empty = TRUE;
3295 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3297 _ckvmssts_noperl(iss);
3301 b->size = p->iosb.count;
3302 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3304 p->need_wake = FALSE;
3305 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3308 p->retry = 1; /* initial call */
3311 if (eof) { /* flush the free queue, return when done */
3312 int n = sizeof(CBuf) + p->bufsize;
3314 iss = lib$remqti(&p->free, &b);
3315 if (iss == LIB$_QUEWASEMP) return;
3316 _ckvmssts_noperl(iss);
3317 _ckvmssts_noperl(lib$free_vm(&n, &b));
3321 iss = lib$remqti(&p->free, &b);
3322 if (iss == LIB$_QUEWASEMP) {
3323 int n = sizeof(CBuf) + p->bufsize;
3324 _ckvmssts_noperl(lib$get_vm(&n, &b));
3325 b->buf = (char *) b + sizeof(CBuf);
3327 _ckvmssts_noperl(iss);
3331 iss = sys$qio(0,p->chan_in,
3332 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3334 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3335 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3336 _ckvmssts_noperl(iss);
3340 /* writes queued buffers to output, waits for each to complete before
3344 pipe_tochild2_ast(pPipe p)
3347 int iss = p->iosb2.status;
3348 int n = sizeof(CBuf) + p->bufsize;
3349 int done = (p->info && p->info->done) ||
3350 iss == SS$_CANCEL || iss == SS$_ABORT;
3351 #if defined(PERL_IMPLICIT_CONTEXT)
3356 if (p->type) { /* type=1 has old buffer, dispose */
3357 if (p->shut_on_empty) {
3358 _ckvmssts_noperl(lib$free_vm(&n, &b));
3360 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3365 iss = lib$remqti(&p->wait, &b);
3366 if (iss == LIB$_QUEWASEMP) {
3367 if (p->shut_on_empty) {
3369 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3370 *p->pipe_done = TRUE;
3371 _ckvmssts_noperl(sys$setef(pipe_ef));
3373 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3374 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3378 p->need_wake = TRUE;
3381 _ckvmssts_noperl(iss);
3388 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3389 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3391 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3392 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3401 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3404 char mbx1[64], mbx2[64];
3405 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3406 DSC$K_CLASS_S, mbx1},
3407 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3408 DSC$K_CLASS_S, mbx2};
3409 unsigned int dviitm = DVI$_DEVBUFSIZ;
3411 int n = sizeof(Pipe);
3412 _ckvmssts_noperl(lib$get_vm(&n, &p));
3413 create_mbx(&p->chan_in , &d_mbx1);
3414 create_mbx(&p->chan_out, &d_mbx2);
3416 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3417 n = p->bufsize * sizeof(char);
3418 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3419 p->shut_on_empty = FALSE;
3422 p->iosb.status = SS$_NORMAL;
3423 #if defined(PERL_IMPLICIT_CONTEXT)
3426 pipe_infromchild_ast(p);
3434 pipe_infromchild_ast(pPipe p)
3436 int iss = p->iosb.status;
3437 int eof = (iss == SS$_ENDOFFILE);
3438 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3439 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3440 #if defined(PERL_IMPLICIT_CONTEXT)
3444 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3445 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3450 input shutdown if EOF from self (done or shut_on_empty)
3451 output shutdown if closing flag set (my_pclose)
3452 send data/eof from child or eof from self
3453 otherwise, re-read (snarf of data from child)
3458 if (myeof && p->chan_in) { /* input shutdown */
3459 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3464 if (myeof || kideof) { /* pass EOF to parent */
3465 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3466 pipe_infromchild_ast, p,
3469 } else if (eof) { /* eat EOF --- fall through to read*/
3471 } else { /* transmit data */
3472 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3473 pipe_infromchild_ast,p,
3474 p->buf, p->iosb.count, 0, 0, 0, 0));
3480 /* everything shut? flag as done */
3482 if (!p->chan_in && !p->chan_out) {
3483 *p->pipe_done = TRUE;
3484 _ckvmssts_noperl(sys$setef(pipe_ef));
3488 /* write completed (or read, if snarfing from child)
3489 if still have input active,
3490 queue read...immediate mode if shut_on_empty so we get EOF if empty
3492 check if Perl reading, generate EOFs as needed
3498 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3499 pipe_infromchild_ast,p,
3500 p->buf, p->bufsize, 0, 0, 0, 0);
3501 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3502 _ckvmssts_noperl(iss);
3503 } else { /* send EOFs for extra reads */
3504 p->iosb.status = SS$_ENDOFFILE;
3505 p->iosb.dvispec = 0;
3506 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3508 pipe_infromchild_ast, p, 0, 0, 0, 0));
3514 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3518 unsigned long dviitm = DVI$_DEVBUFSIZ;
3520 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3521 DSC$K_CLASS_S, mbx};
3522 int n = sizeof(Pipe);
3524 /* things like terminals and mbx's don't need this filter */
3525 if (fd && fstat(fd,&s) == 0) {
3526 unsigned long devchar;
3528 unsigned short dev_len;
3529 struct dsc$descriptor_s d_dev;
3531 struct item_list_3 items[3];
3533 unsigned short dvi_iosb[4];
3535 cptr = getname(fd, out, 1);
3536 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3537 d_dev.dsc$a_pointer = out;
3538 d_dev.dsc$w_length = strlen(out);
3539 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3540 d_dev.dsc$b_class = DSC$K_CLASS_S;
3543 items[0].code = DVI$_DEVCHAR;
3544 items[0].bufadr = &devchar;
3545 items[0].retadr = NULL;
3547 items[1].code = DVI$_FULLDEVNAM;
3548 items[1].bufadr = device;
3549 items[1].retadr = &dev_len;
3553 status = sys$getdviw
3554 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3555 _ckvmssts_noperl(status);
3556 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3557 device[dev_len] = 0;
3559 if (!(devchar & DEV$M_DIR)) {
3560 strcpy(out, device);
3566 _ckvmssts_noperl(lib$get_vm(&n, &p));
3567 p->fd_out = dup(fd);
3568 create_mbx(&p->chan_in, &d_mbx);
3569 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3570 n = (p->bufsize+1) * sizeof(char);
3571 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3572 p->shut_on_empty = FALSE;
3577 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3578 pipe_mbxtofd_ast, p,
3579 p->buf, p->bufsize, 0, 0, 0, 0));
3585 pipe_mbxtofd_ast(pPipe p)
3587 int iss = p->iosb.status;
3588 int done = p->info->done;
3590 int eof = (iss == SS$_ENDOFFILE);
3591 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3592 int err = !(iss&1) && !eof;
3593 #if defined(PERL_IMPLICIT_CONTEXT)
3597 if (done && myeof) { /* end piping */
3599 sys$dassgn(p->chan_in);
3600 *p->pipe_done = TRUE;
3601 _ckvmssts_noperl(sys$setef(pipe_ef));
3605 if (!err && !eof) { /* good data to send to file */
3606 p->buf[p->iosb.count] = '\n';
3607 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3610 if (p->retry < MAX_RETRY) {
3611 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3617 _ckvmssts_noperl(iss);
3621 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3622 pipe_mbxtofd_ast, p,
3623 p->buf, p->bufsize, 0, 0, 0, 0);
3624 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3625 _ckvmssts_noperl(iss);
3629 typedef struct _pipeloc PLOC;
3630 typedef struct _pipeloc* pPLOC;
3634 char dir[NAM$C_MAXRSS+1];
3636 static pPLOC head_PLOC = 0;
3639 free_pipelocs(pTHX_ void *head)
3642 pPLOC *pHead = (pPLOC *)head;
3654 store_pipelocs(pTHX)
3662 char temp[NAM$C_MAXRSS+1];
3666 free_pipelocs(aTHX_ &head_PLOC);
3668 /* the . directory from @INC comes last */
3670 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3671 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3672 p->next = head_PLOC;
3674 strcpy(p->dir,"./");
3676 /* get the directory from $^X */
3678 unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3679 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3681 #ifdef PERL_IMPLICIT_CONTEXT
3682 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3684 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3686 my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3687 x = strrchr(temp,']');
3689 x = strrchr(temp,'>');
3691 /* It could be a UNIX path */
3692 x = strrchr(temp,'/');
3698 /* Got a bare name, so use default directory */
3703 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3704 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3705 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3706 p->next = head_PLOC;
3708 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3712 /* reverse order of @INC entries, skip "." since entered above */
3714 #ifdef PERL_IMPLICIT_CONTEXT
3717 if (PL_incgv) av = GvAVn(PL_incgv);
3719 for (i = 0; av && i <= AvFILL(av); i++) {
3720 dirsv = *av_fetch(av,i,TRUE);
3722 if (SvROK(dirsv)) continue;
3723 dir = SvPVx(dirsv,n_a);
3724 if (strcmp(dir,".") == 0) continue;
3725 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3728 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3729 p->next = head_PLOC;
3731 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3734 /* most likely spot (ARCHLIB) put first in the list */
3737 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3738 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3739 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3740 p->next = head_PLOC;
3742 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3745 PerlMem_free(unixdir);
3748 static I32 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective,
3749 const char *fname, int opts);
3750 #if !defined(PERL_IMPLICIT_CONTEXT)
3751 #define cando_by_name_int Perl_cando_by_name_int
3753 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3759 static int vmspipe_file_status = 0;
3760 static char vmspipe_file[NAM$C_MAXRSS+1];
3762 /* already found? Check and use ... need read+execute permission */
3764 if (vmspipe_file_status == 1) {
3765 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3766 && cando_by_name_int
3767 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3768 return vmspipe_file;
3770 vmspipe_file_status = 0;
3773 /* scan through stored @INC, $^X */
3775 if (vmspipe_file_status == 0) {
3776 char file[NAM$C_MAXRSS+1];
3777 pPLOC p = head_PLOC;
3782 dirlen = my_strlcpy(file, p->dir, sizeof(file));
3783 my_strlcat(file, "vmspipe.com", sizeof(file));
3786 exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3787 if (!exp_res) continue;
3789 if (cando_by_name_int
3790 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3791 && cando_by_name_int
3792 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3793 vmspipe_file_status = 1;
3794 return vmspipe_file;
3797 vmspipe_file_status = -1; /* failed, use tempfiles */
3804 vmspipe_tempfile(pTHX)
3806 char file[NAM$C_MAXRSS+1];
3808 static int index = 0;
3812 /* create a tempfile */
3814 /* we can't go from W, shr=get to R, shr=get without
3815 an intermediate vulnerable state, so don't bother trying...
3817 and lib$spawn doesn't shr=put, so have to close the write
3819 So... match up the creation date/time and the FID to
3820 make sure we're dealing with the same file
3825 if (!decc_filename_unix_only) {
3826 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3827 fp = fopen(file,"w");
3829 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3830 fp = fopen(file,"w");
3832 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3833 fp = fopen(file,"w");
3838 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3839 fp = fopen(file,"w");
3841 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3842 fp = fopen(file,"w");
3844 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3845 fp = fopen(file,"w");
3849 if (!fp) return 0; /* we're hosed */
3851 fprintf(fp,"$! 'f$verify(0)'\n");
3852 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3853 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3854 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3855 fprintf(fp,"$ perl_on = \"set noon\"\n");
3856 fprintf(fp,"$ perl_exit = \"exit\"\n");
3857 fprintf(fp,"$ perl_del = \"delete\"\n");
3858 fprintf(fp,"$ pif = \"if\"\n");
3859 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3860 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3861 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3862 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3863 fprintf(fp,"$! --- build command line to get max possible length\n");
3864 fprintf(fp,"$c=perl_popen_cmd0\n");
3865 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3866 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3867 fprintf(fp,"$x=perl_popen_cmd3\n");
3868 fprintf(fp,"$c=c+x\n");
3869 fprintf(fp,"$ perl_on\n");
3870 fprintf(fp,"$ 'c'\n");
3871 fprintf(fp,"$ perl_status = $STATUS\n");
3872 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3873 fprintf(fp,"$ perl_exit 'perl_status'\n");
3876 fgetname(fp, file, 1);
3877 fstat(fileno(fp), &s0.crtl_stat);
3880 if (decc_filename_unix_only)
3881 int_tounixspec(file, file, NULL);
3882 fp = fopen(file,"r","shr=get");
3884 fstat(fileno(fp), &s1.crtl_stat);
3886 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3887 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3897 vms_is_syscommand_xterm(void)
3899 const static struct dsc$descriptor_s syscommand_dsc =
3900 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3902 const static struct dsc$descriptor_s decwdisplay_dsc =
3903 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3905 struct item_list_3 items[2];
3906 unsigned short dvi_iosb[4];
3907 unsigned long devchar;
3908 unsigned long devclass;
3911 /* Very simple check to guess if sys$command is a decterm? */
3912 /* First see if the DECW$DISPLAY: device exists */
3914 items[0].code = DVI$_DEVCHAR;
3915 items[0].bufadr = &devchar;
3916 items[0].retadr = NULL;
3920 status = sys$getdviw
3921 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3923 if ($VMS_STATUS_SUCCESS(status)) {
3924 status = dvi_iosb[0];
3927 if (!$VMS_STATUS_SUCCESS(status)) {
3928 SETERRNO(EVMSERR, status);
3932 /* If it does, then for now assume that we are on a workstation */
3933 /* Now verify that SYS$COMMAND is a terminal */
3934 /* for creating the debugger DECTerm */
3937 items[0].code = DVI$_DEVCLASS;
3938 items[0].bufadr = &devclass;
3939 items[0].retadr = NULL;
3943 status = sys$getdviw
3944 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3946 if ($VMS_STATUS_SUCCESS(status)) {
3947 status = dvi_iosb[0];
3950 if (!$VMS_STATUS_SUCCESS(status)) {
3951 SETERRNO(EVMSERR, status);
3955 if (devclass == DC$_TERM) {
3962 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3964 create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3969 char device_name[65];
3970 unsigned short device_name_len;
3971 struct dsc$descriptor_s customization_dsc;
3972 struct dsc$descriptor_s device_name_dsc;
3974 char customization[200];
3978 unsigned short p_chan;
3980 unsigned short iosb[4];
3981 const char * cust_str =
3982 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3983 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3984 DSC$K_CLASS_S, mbx1};
3986 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3987 /*---------------------------------------*/
3988 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3991 /* Make sure that this is from the Perl debugger */
3992 ret_char = strstr(cmd," xterm ");
3993 if (ret_char == NULL)
3995 cptr = ret_char + 7;
3996 ret_char = strstr(cmd,"tty");
3997 if (ret_char == NULL)
3999 ret_char = strstr(cmd,"sleep");
4000 if (ret_char == NULL)
4003 if (decw_term_port == 0) {
4004 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4005 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4006 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4008 status = lib$find_image_symbol
4010 &decw_term_port_dsc,
4011 (void *)&decw_term_port,
4015 /* Try again with the other image name */
4016 if (!$VMS_STATUS_SUCCESS(status)) {
4018 status = lib$find_image_symbol
4020 &decw_term_port_dsc,
4021 (void *)&decw_term_port,
4030 /* No decw$term_port, give it up */
4031 if (!$VMS_STATUS_SUCCESS(status))
4034 /* Are we on a workstation? */
4035 /* to do: capture the rows / columns and pass their properties */
4036 ret_stat = vms_is_syscommand_xterm();
4040 /* Make the title: */
4041 ret_char = strstr(cptr,"-title");
4042 if (ret_char != NULL) {
4043 while ((*cptr != 0) && (*cptr != '\"')) {
4049 while ((*cptr != 0) && (*cptr != '\"')) {
4062 strcpy(title,"Perl Debug DECTerm");
4064 sprintf(customization, cust_str, title);
4066 customization_dsc.dsc$a_pointer = customization;
4067 customization_dsc.dsc$w_length = strlen(customization);
4068 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4069 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4071 device_name_dsc.dsc$a_pointer = device_name;
4072 device_name_dsc.dsc$w_length = sizeof device_name -1;
4073 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4074 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4076 device_name_len = 0;
4078 /* Try to create the window */
4079 status = (*decw_term_port)
4088 if (!$VMS_STATUS_SUCCESS(status)) {
4089 SETERRNO(EVMSERR, status);
4093 device_name[device_name_len] = '\0';
4095 /* Need to set this up to look like a pipe for cleanup */
4097 status = lib$get_vm(&n, &info);
4098 if (!$VMS_STATUS_SUCCESS(status)) {
4099 SETERRNO(ENOMEM, status);
4105 info->completion = 0;
4106 info->closing = FALSE;
4113 info->in_done = TRUE;
4114 info->out_done = TRUE;
4115 info->err_done = TRUE;
4117 /* Assign a channel on this so that it will persist, and not login */
4118 /* We stash this channel in the info structure for reference. */
4119 /* The created xterm self destructs when the last channel is removed */
4120 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4121 /* So leave this assigned. */
4122 device_name_dsc.dsc$w_length = device_name_len;
4123 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4124 if (!$VMS_STATUS_SUCCESS(status)) {
4125 SETERRNO(EVMSERR, status);
4128 info->xchan_valid = 1;
4130 /* Now create a mailbox to be read by the application */
4132 create_mbx(&p_chan, &d_mbx1);
4134 /* write the name of the created terminal to the mailbox */
4135 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4136 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4138 if (!$VMS_STATUS_SUCCESS(status)) {
4139 SETERRNO(EVMSERR, status);
4143 info->fp = PerlIO_open(mbx1, mode);
4145 /* Done with this channel */
4148 /* If any errors, then clean up */
4151 _ckvmssts_noperl(lib$free_vm(&n, &info));
4159 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4162 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4164 static int handler_set_up = FALSE;
4166 unsigned long int sts, flags = CLI$M_NOWAIT;
4167 /* The use of a GLOBAL table (as was done previously) rendered
4168 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4169 * environment. Hence we've switched to LOCAL symbol table.
4171 unsigned int table = LIB$K_CLI_LOCAL_SYM;
4173 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4174 char *in, *out, *err, mbx[512];
4176 char tfilebuf[NAM$C_MAXRSS+1];
4178 char cmd_sym_name[20];
4179 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4180 DSC$K_CLASS_S, symbol};
4181 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4183 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4184 DSC$K_CLASS_S, cmd_sym_name};
4185 struct dsc$descriptor_s *vmscmd;
4186 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4187 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4188 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4190 /* Check here for Xterm create request. This means looking for
4191 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4192 * is possible to create an xterm.
4194 if (*in_mode == 'r') {
4197 #if defined(PERL_IMPLICIT_CONTEXT)
4198 /* Can not fork an xterm with a NULL context */
4199 /* This probably could never happen */
4203 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4204 if (xterm_fd != NULL)
4208 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4210 /* once-per-program initialization...
4211 note that the SETAST calls and the dual test of pipe_ef
4212 makes sure that only the FIRST thread through here does
4213 the initialization...all other threads wait until it's
4216 Yeah, uglier than a pthread call, it's got all the stuff inline
4217 rather than in a separate routine.
4221 _ckvmssts_noperl(sys$setast(0));
4223 unsigned long int pidcode = JPI$_PID;
4224 $DESCRIPTOR(d_delay, RETRY_DELAY);
4225 _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4226 _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4227 _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4229 if (!handler_set_up) {
4230 _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4231 handler_set_up = TRUE;
4233 _ckvmssts_noperl(sys$setast(1));
4236 /* see if we can find a VMSPIPE.COM */
4239 vmspipe = find_vmspipe(aTHX);
4241 vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4242 } else { /* uh, oh...we're in tempfile hell */
4243 tpipe = vmspipe_tempfile(aTHX);
4244 if (!tpipe) { /* a fish popular in Boston */
4245 if (ckWARN(WARN_PIPE)) {
4246 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4250 fgetname(tpipe,tfilebuf+1,1);
4251 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4253 vmspipedsc.dsc$a_pointer = tfilebuf;
4255 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4258 case RMS$_FNF: case RMS$_DNF:
4259 set_errno(ENOENT); break;
4261 set_errno(ENOTDIR); break;
4263 set_errno(ENODEV); break;
4265 set_errno(EACCES); break;
4267 set_errno(EINVAL); break;
4268 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4269 set_errno(E2BIG); break;
4270 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4271 _ckvmssts_noperl(sts); /* fall through */
4272 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4275 set_vaxc_errno(sts);
4276 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4277 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4283 _ckvmssts_noperl(lib$get_vm(&n, &info));
4285 my_strlcpy(mode, in_mode, sizeof(mode));
4288 info->completion = 0;
4289 info->closing = FALSE;
4296 info->in_done = TRUE;
4297 info->out_done = TRUE;
4298 info->err_done = TRUE;
4300 info->xchan_valid = 0;
4302 in = (char *)PerlMem_malloc(VMS_MAXRSS);
4303 if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4304 out = (char *)PerlMem_malloc(VMS_MAXRSS);
4305 if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4306 err = (char *)PerlMem_malloc(VMS_MAXRSS);
4307 if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4309 in[0] = out[0] = err[0] = '\0';
4311 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4315 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4320 if (*mode == 'r') { /* piping from subroutine */
4322 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4324 info->out->pipe_done = &info->out_done;
4325 info->out_done = FALSE;
4326 info->out->info = info;
4328 if (!info->useFILE) {
4329 info->fp = PerlIO_open(mbx, mode);
4331 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4332 vmssetuserlnm("SYS$INPUT", mbx);
4335 if (!info->fp && info->out) {
4336 sys$cancel(info->out->chan_out);
4338 while (!info->out_done) {
4340 _ckvmssts_noperl(sys$setast(0));
4341 done = info->out_done;
4342 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4343 _ckvmssts_noperl(sys$setast(1));
4344 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4347 if (info->out->buf) {
4348 n = info->out->bufsize * sizeof(char);
4349 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4352 _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4354 _ckvmssts_noperl(lib$free_vm(&n, &info));
4359 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4361 info->err->pipe_done = &info->err_done;
4362 info->err_done = FALSE;
4363 info->err->info = info;
4366 } else if (*mode == 'w') { /* piping to subroutine */
4368 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4370 info->out->pipe_done = &info->out_done;
4371 info->out_done = FALSE;
4372 info->out->info = info;
4375 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4377 info->err->pipe_done = &info->err_done;
4378 info->err_done = FALSE;
4379 info->err->info = info;
4382 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4383 if (!info->useFILE) {
4384 info->fp = PerlIO_open(mbx, mode);
4386 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4387 vmssetuserlnm("SYS$OUTPUT", mbx);
4391 info->in->pipe_done = &info->in_done;
4392 info->in_done = FALSE;
4393 info->in->info = info;
4397 if (!info->fp && info->in) {
4399 _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4400 0, 0, 0, 0, 0, 0, 0, 0));
4402 while (!info->in_done) {
4404 _ckvmssts_noperl(sys$setast(0));
4405 done = info->in_done;
4406 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4407 _ckvmssts_noperl(sys$setast(1));
4408 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4411 if (info->in->buf) {
4412 n = info->in->bufsize * sizeof(char);
4413 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4416 _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4418 _ckvmssts_noperl(lib$free_vm(&n, &info));
4424 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4425 /* Let the child inherit standard input, unless it's a directory. */
4427 if (my_trnlnm("SYS$INPUT", in, 0)) {
4428 if (flex_stat(in, &st) != 0 || S_ISDIR(st.st_mode))
4432 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4434 info->out->pipe_done = &info->out_done;
4435 info->out_done = FALSE;
4436 info->out->info = info;
4439 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4441 info->err->pipe_done = &info->err_done;
4442 info->err_done = FALSE;
4443 info->err->info = info;
4447 d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4448 _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4450 d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4451 _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4453 d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4454 _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4456 /* Done with the names for the pipes */
4461 p = vmscmd->dsc$a_pointer;
4462 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4463 if (*p == '$') p++; /* remove leading $ */
4464 while (*p == ' ' || *p == '\t') p++;
4466 for (j = 0; j < 4; j++) {
4467 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4468 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4470 d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4471 _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4473 if (strlen(p) > MAX_DCL_SYMBOL) {
4474 p += MAX_DCL_SYMBOL;
4479 _ckvmssts_noperl(sys$setast(0));
4480 info->next=open_pipes; /* prepend to list */
4482 _ckvmssts_noperl(sys$setast(1));
4483 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4484 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4485 * have SYS$COMMAND if we need it.
4487 _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4488 0, &info->pid, &info->completion,
4489 0, popen_completion_ast,info,0,0,0));
4491 /* if we were using a tempfile, close it now */
4493 if (tpipe) fclose(tpipe);
4495 /* once the subprocess is spawned, it has copied the symbols and
4496 we can get rid of ours */
4498 for (j = 0; j < 4; j++) {
4499 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4500 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4501 _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4503 _ckvmssts_noperl(lib$delete_symbol(&d_sym_in, &table));
4504 _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4505 _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4506 vms_execfree(vmscmd);
4508 #ifdef PERL_IMPLICIT_CONTEXT
4511 PL_forkprocess = info->pid;
4518 _ckvmssts_noperl(sys$setast(0));
4520 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4521 _ckvmssts_noperl(sys$setast(1));
4522 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4524 *psts = info->completion;
4525 /* Caller thinks it is open and tries to close it. */
4526 /* This causes some problems, as it changes the error status */
4527 /* my_pclose(info->fp); */
4529 /* If we did not have a file pointer open, then we have to */
4530 /* clean up here or eventually we will run out of something */
4532 if (info->fp == NULL) {
4533 my_pclose_pinfo(aTHX_ info);
4541 } /* end of safe_popen */
4544 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4546 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4550 TAINT_PROPER("popen");
4551 PERL_FLUSHALL_FOR_CHILD;
4552 return safe_popen(aTHX_ cmd,mode,&sts);
4558 /* Routine to close and cleanup a pipe info structure */
4561 my_pclose_pinfo(pTHX_ pInfo info) {
4563 unsigned long int retsts;
4567 /* If we were writing to a subprocess, insure that someone reading from
4568 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4569 * produce an EOF record in the mailbox.
4571 * well, at least sometimes it *does*, so we have to watch out for
4572 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4576 #if defined(USE_ITHREADS)
4580 && PL_perlio_fd_refcnt
4583 PerlIO_flush(info->fp);
4585 fflush((FILE *)info->fp);
4588 _ckvmssts(sys$setast(0));
4589 info->closing = TRUE;
4590 done = info->done && info->in_done && info->out_done && info->err_done;
4591 /* hanging on write to Perl's input? cancel it */
4592 if (info->mode == 'r' && info->out && !info->out_done) {
4593 if (info->out->chan_out) {
4594 _ckvmssts(sys$cancel(info->out->chan_out));
4595 if (!info->out->chan_in) { /* EOF generation, need AST */
4596 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4600 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4601 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4603 _ckvmssts(sys$setast(1));
4606 #if defined(USE_ITHREADS)
4610 && PL_perlio_fd_refcnt
4613 PerlIO_close(info->fp);
4615 fclose((FILE *)info->fp);
4618 we have to wait until subprocess completes, but ALSO wait until all
4619 the i/o completes...otherwise we'll be freeing the "info" structure
4620 that the i/o ASTs could still be using...
4624 _ckvmssts(sys$setast(0));
4625 done = info->done && info->in_done && info->out_done && info->err_done;
4626 if (!done) _ckvmssts(sys$clref(pipe_ef));
4627 _ckvmssts(sys$setast(1));
4628 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4630 retsts = info->completion;
4632 /* remove from list of open pipes */
4633 _ckvmssts(sys$setast(0));
4635 for (next = open_pipes; next != NULL; last = next, next = next->next) {
4641 last->next = info->next;
4643 open_pipes = info->next;
4644 _ckvmssts(sys$setast(1));
4646 /* free buffers and structures */
4649 if (info->in->buf) {
4650 n = info->in->bufsize * sizeof(char);
4651 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4654 _ckvmssts(lib$free_vm(&n, &info->in));
4657 if (info->out->buf) {
4658 n = info->out->bufsize * sizeof(char);
4659 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4662 _ckvmssts(lib$free_vm(&n, &info->out));
4665 if (info->err->buf) {
4666 n = info->err->bufsize * sizeof(char);
4667 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4670 _ckvmssts(lib$free_vm(&n, &info->err));
4673 _ckvmssts(lib$free_vm(&n, &info));
4679 /*{{{ I32 my_pclose(PerlIO *fp)*/
4680 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4682 pInfo info, last = NULL;
4685 /* Fixme - need ast and mutex protection here */
4686 for (info = open_pipes; info != NULL; last = info, info = info->next)
4687 if (info->fp == fp) break;
4689 if (info == NULL) { /* no such pipe open */
4690 set_errno(ECHILD); /* quoth POSIX */
4691 set_vaxc_errno(SS$_NONEXPR);
4695 ret_status = my_pclose_pinfo(aTHX_ info);
4699 } /* end of my_pclose() */
4701 /* Roll our own prototype because we want this regardless of whether
4702 * _VMS_WAIT is defined.
4708 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4713 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4714 created with popen(); otherwise partially emulate waitpid() unless
4715 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4716 Also check processes not considered by the CRTL waitpid().
4718 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4720 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4727 if (statusp) *statusp = 0;
4729 for (info = open_pipes; info != NULL; info = info->next)
4730 if (info->pid == pid) break;
4732 if (info != NULL) { /* we know about this child */
4733 while (!info->done) {
4734 _ckvmssts(sys$setast(0));
4736 if (!done) _ckvmssts(sys$clref(pipe_ef));
4737 _ckvmssts(sys$setast(1));
4738 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4741 if (statusp) *statusp = info->completion;
4745 /* child that already terminated? */
4747 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4748 if (closed_list[j].pid == pid) {
4749 if (statusp) *statusp = closed_list[j].completion;
4754 /* fall through if this child is not one of our own pipe children */
4756 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4757 * in 7.2 did we get a version that fills in the VMS completion
4758 * status as Perl has always tried to do.
4761 sts = __vms_waitpid( pid, statusp, flags );
4763 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4766 /* If the real waitpid tells us the child does not exist, we
4767 * fall through here to implement waiting for a child that
4768 * was created by some means other than exec() (say, spawned
4769 * from DCL) or to wait for a process that is not a subprocess
4770 * of the current process.
4774 $DESCRIPTOR(intdsc,"0 00:00:01");
4775 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4776 unsigned long int pidcode = JPI$_PID, mypid;
4777 unsigned long int interval[2];
4778 unsigned int jpi_iosb[2];
4779 struct itmlst_3 jpilist[2] = {
4780 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4785 /* Sorry folks, we don't presently implement rooting around for
4786 the first child we can find, and we definitely don't want to
4787 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4793 /* Get the owner of the child so I can warn if it's not mine. If the
4794 * process doesn't exist or I don't have the privs to look at it,
4795 * I can go home early.
4797 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4798 if (sts & 1) sts = jpi_iosb[0];
4810 set_vaxc_errno(sts);
4814 if (ckWARN(WARN_EXEC)) {
4815 /* remind folks they are asking for non-standard waitpid behavior */
4816 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4817 if (ownerpid != mypid)
4818 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4819 "waitpid: process %x is not a child of process %x",
4823 /* simply check on it once a second until it's not there anymore. */
4825 _ckvmssts(sys$bintim(&intdsc,interval));
4826 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4827 _ckvmssts(sys$schdwk(0,0,interval,0));
4828 _ckvmssts(sys$hiber());
4830 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4835 } /* end of waitpid() */
4840 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4842 my_gconvert(double val, int ndig, int trail, char *buf)
4844 static char __gcvtbuf[DBL_DIG+1];
4847 loc = buf ? buf : __gcvtbuf;
4850 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4851 return gcvt(val,ndig,loc);
4854 loc[0] = '0'; loc[1] = '\0';
4861 #if !defined(NAML$C_MAXRSS)
4863 rms_free_search_context(struct FAB * fab)
4867 nam = fab->fab$l_nam;
4868 nam->nam$b_nop |= NAM$M_SYNCHK;
4869 nam->nam$l_rlf = NULL;
4871 return sys$parse(fab, NULL, NULL);
4874 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4875 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4876 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4877 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4878 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4879 #define rms_nam_esll(nam) nam.nam$b_esl
4880 #define rms_nam_esl(nam) nam.nam$b_esl
4881 #define rms_nam_name(nam) nam.nam$l_name
4882 #define rms_nam_namel(nam) nam.nam$l_name
4883 #define rms_nam_type(nam) nam.nam$l_type
4884 #define rms_nam_typel(nam) nam.nam$l_type
4885 #define rms_nam_ver(nam) nam.nam$l_ver
4886 #define rms_nam_verl(nam) nam.nam$l_ver
4887 #define rms_nam_rsll(nam) nam.nam$b_rsl
4888 #define rms_nam_rsl(nam) nam.nam$b_rsl
4889 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4890 #define rms_set_fna(fab, nam, name, size) \
4891 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4892 #define rms_get_fna(fab, nam) fab.fab$l_fna
4893 #define rms_set_dna(fab, nam, name, size) \
4894 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4895 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4896 #define rms_set_esa(nam, name, size) \
4897 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4898 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4899 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4900 #define rms_set_rsa(nam, name, size) \
4901 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4902 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4903 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4904 #define rms_nam_name_type_l_size(nam) \
4905 (nam.nam$b_name + nam.nam$b_type)
4908 rms_free_search_context(struct FAB * fab)
4912 nam = fab->fab$l_naml;
4913 nam->naml$b_nop |= NAM$M_SYNCHK;
4914 nam->naml$l_rlf = NULL;
4915 nam->naml$l_long_defname_size = 0;
4918 return sys$parse(fab, NULL, NULL);
4921 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4922 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4923 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4924 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4925 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4926 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4927 #define rms_nam_esl(nam) nam.naml$b_esl
4928 #define rms_nam_name(nam) nam.naml$l_name
4929 #define rms_nam_namel(nam) nam.naml$l_long_name
4930 #define rms_nam_type(nam) nam.naml$l_type
4931 #define rms_nam_typel(nam) nam.naml$l_long_type
4932 #define rms_nam_ver(nam) nam.naml$l_ver
4933 #define rms_nam_verl(nam) nam.naml$l_long_ver
4934 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4935 #define rms_nam_rsl(nam) nam.naml$b_rsl
4936 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4937 #define rms_set_fna(fab, nam, name, size) \
4938 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4939 nam.naml$l_long_filename_size = size; \
4940 nam.naml$l_long_filename = name;}
4941 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4942 #define rms_set_dna(fab, nam, name, size) \
4943 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4944 nam.naml$l_long_defname_size = size; \
4945 nam.naml$l_long_defname = name; }
4946 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4947 #define rms_set_esa(nam, name, size) \
4948 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4949 nam.naml$l_long_expand_alloc = size; \
4950 nam.naml$l_long_expand = name; }
4951 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4952 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4953 nam.naml$l_long_expand = l_name; \
4954 nam.naml$l_long_expand_alloc = l_size; }
4955 #define rms_set_rsa(nam, name, size) \
4956 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4957 nam.naml$l_long_result = name; \
4958 nam.naml$l_long_result_alloc = size; }
4959 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4960 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4961 nam.naml$l_long_result = l_name; \
4962 nam.naml$l_long_result_alloc = l_size; }
4963 #define rms_nam_name_type_l_size(nam) \
4964 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4969 * The CRTL for 8.3 and later can create symbolic links in any mode,
4970 * however in 8.3 the unlink/remove/delete routines will only properly handle
4971 * them if one of the PCP modes is active.
4974 rms_erase(const char * vmsname)
4977 struct FAB myfab = cc$rms_fab;
4978 rms_setup_nam(mynam);
4980 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4981 rms_bind_fab_nam(myfab, mynam);
4983 #ifdef NAML$M_OPEN_SPECIAL
4984 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4987 status = sys$erase(&myfab, 0, 0);
4994 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4995 const struct dsc$descriptor_s * vms_dst_dsc,
4996 unsigned long flags)
4998 /* VMS and UNIX handle file permissions differently and the
4999 * the same ACL trick may be needed for renaming files,
5000 * especially if they are directories.
5003 /* todo: get kill_file and rename to share common code */
5004 /* I can not find online documentation for $change_acl
5005 * it appears to be replaced by $set_security some time ago */
5007 const unsigned int access_mode = 0;
5008 $DESCRIPTOR(obj_file_dsc,"FILE");
5011 unsigned long int jpicode = JPI$_UIC;
5012 int aclsts, fndsts, rnsts = -1;
5013 unsigned int ctx = 0;
5014 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5015 struct dsc$descriptor_s * clean_dsc;
5018 unsigned char myace$b_length;
5019 unsigned char myace$b_type;
5020 unsigned short int myace$w_flags;
5021 unsigned long int myace$l_access;
5022 unsigned long int myace$l_ident;
5023 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5024 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5026 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5029 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5030 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5032 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5033 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5037 /* Expand the input spec using RMS, since we do not want to put
5038 * ACLs on the target of a symbolic link */
5039 vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
5040 if (vmsname == NULL)
5043 rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5045 PERL_RMSEXPAND_M_SYMLINK);
5047 PerlMem_free(vmsname);
5051 /* So we get our own UIC to use as a rights identifier,
5052 * and the insert an ACE at the head of the ACL which allows us
5053 * to delete the file.
5055 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5057 fildsc.dsc$w_length = strlen(vmsname);
5058 fildsc.dsc$a_pointer = vmsname;
5060 newace.myace$l_ident = oldace.myace$l_ident;
5063 /* Grab any existing ACEs with this identifier in case we fail */
5064 clean_dsc = &fildsc;
5065 aclsts = fndsts = sys$get_security(&obj_file_dsc,
5073 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
5074 /* Add the new ACE . . . */
5076 /* if the sys$get_security succeeded, then ctx is valid, and the
5077 * object/file descriptors will be ignored. But otherwise they
5080 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5081 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5082 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5084 set_vaxc_errno(aclsts);
5085 PerlMem_free(vmsname);
5089 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5092 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5094 if ($VMS_STATUS_SUCCESS(rnsts)) {
5095 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5098 /* Put things back the way they were. */
5100 aclsts = sys$get_security(&obj_file_dsc,
5108 if ($VMS_STATUS_SUCCESS(aclsts)) {
5112 if (!$VMS_STATUS_SUCCESS(fndsts))
5113 sec_flags = OSS$M_RELCTX;
5115 /* Get rid of the new ACE */
5116 aclsts = sys$set_security(NULL, NULL, NULL,
5117 sec_flags, dellst, &ctx, &access_mode);
5119 /* If there was an old ACE, put it back */
5120 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5121 addlst[0].bufadr = &oldace;
5122 aclsts = sys$set_security(NULL, NULL, NULL,
5123 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5124 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5126 set_vaxc_errno(aclsts);
5132 /* Try to clear the lock on the ACL list */
5133 aclsts2 = sys$set_security(NULL, NULL, NULL,
5134 OSS$M_RELCTX, NULL, &ctx, &access_mode);
5136 /* Rename errors are most important */
5137 if (!$VMS_STATUS_SUCCESS(rnsts))
5140 set_vaxc_errno(aclsts);
5145 if (aclsts != SS$_ACLEMPTY)
5152 PerlMem_free(vmsname);
5157 /*{{{int rename(const char *, const char * */
5158 /* Not exactly what X/Open says to do, but doing it absolutely right
5159 * and efficiently would require a lot more work. This should be close
5160 * enough to pass all but the most strict X/Open compliance test.
5163 Perl_rename(pTHX_ const char *src, const char * dst)
5172 /* Validate the source file */
5173 src_sts = flex_lstat(src, &src_st);
5176 /* No source file or other problem */
5179 if (src_st.st_devnam[0] == 0) {
5180 /* This may be possible so fail if it is seen. */
5185 dst_sts = flex_lstat(dst, &dst_st);
5188 if (dst_st.st_dev != src_st.st_dev) {
5189 /* Must be on the same device */
5194 /* VMS_INO_T_COMPARE is true if the inodes are different
5195 * to match the output of memcmp
5198 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5199 /* That was easy, the files are the same! */
5203 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5204 /* If source is a directory, so must be dest */
5212 if ((dst_sts == 0) &&
5213 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5215 /* We have issues here if vms_unlink_all_versions is set
5216 * If the destination exists, and is not a directory, then
5217 * we must delete in advance.
5219 * If the src is a directory, then we must always pre-delete
5222 * If we successfully delete the dst in advance, and the rename fails
5223 * X/Open requires that errno be EIO.
5227 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5229 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5230 S_ISDIR(dst_st.st_mode));
5232 /* Need to delete all versions ? */
5233 if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5236 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5237 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5242 /* Make sure that we do not loop forever */
5254 /* We killed the destination, so only errno now is EIO */
5259 /* Originally the idea was to call the CRTL rename() and only
5260 * try the lib$rename_file if it failed.
5261 * It turns out that there are too many variants in what the
5262 * the CRTL rename might do, so only use lib$rename_file
5267 /* Is the source and dest both in VMS format */
5268 /* if the source is a directory, then need to fileify */
5269 /* and dest must be a directory or non-existent. */
5274 unsigned long flags;
5275 struct dsc$descriptor_s old_file_dsc;
5276 struct dsc$descriptor_s new_file_dsc;
5278 /* We need to modify the src and dst depending
5279 * on if one or more of them are directories.
5282 vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
5283 if (vms_dst == NULL)
5284 _ckvmssts_noperl(SS$_INSFMEM);
5286 if (S_ISDIR(src_st.st_mode)) {
5288 char * vms_dir_file;
5290 vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
5291 if (vms_dir_file == NULL)
5292 _ckvmssts_noperl(SS$_INSFMEM);
5294 /* If the dest is a directory, we must remove it */
5297 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5299 PerlMem_free(vms_dst);
5307 /* The dest must be a VMS file specification */
5308 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5309 if (ret_str == NULL) {
5310 PerlMem_free(vms_dst);
5315 /* The source must be a file specification */
5316 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5317 if (ret_str == NULL) {
5318 PerlMem_free(vms_dst);
5319 PerlMem_free(vms_dir_file);
5323 PerlMem_free(vms_dst);
5324 vms_dst = vms_dir_file;
5327 /* File to file or file to new dir */
5329 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5330 /* VMS pathify a dir target */
5331 ret_str = int_tovmspath(dst, vms_dst, NULL);
5332 if (ret_str == NULL) {
5333 PerlMem_free(vms_dst);
5338 char * v_spec, * r_spec, * d_spec, * n_spec;
5339 char * e_spec, * vs_spec;
5340 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5342 /* fileify a target VMS file specification */
5343 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5344 if (ret_str == NULL) {
5345 PerlMem_free(vms_dst);
5350 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5351 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5352 &e_len, &vs_spec, &vs_len);
5355 /* Get rid of the version */
5359 /* Need to specify a '.' so that the extension */
5360 /* is not inherited */
5361 strcat(vms_dst,".");
5367 old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5368 old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5369 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5370 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5372 new_file_dsc.dsc$a_pointer = vms_dst;
5373 new_file_dsc.dsc$w_length = strlen(vms_dst);
5374 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5375 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5378 #if defined(NAML$C_MAXRSS)
5379 flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5382 sts = lib$rename_file(&old_file_dsc,
5386 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5387 if (!$VMS_STATUS_SUCCESS(sts)) {
5389 /* We could have failed because VMS style permissions do not
5390 * permit renames that UNIX will allow. Just like the hack
5393 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5396 PerlMem_free(vms_dst);
5397 if (!$VMS_STATUS_SUCCESS(sts)) {
5404 if (vms_unlink_all_versions) {
5405 /* Now get rid of any previous versions of the source file that
5411 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5412 S_ISDIR(src_st.st_mode));
5413 while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5414 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5415 S_ISDIR(src_st.st_mode));
5420 /* Make sure that we do not loop forever */
5429 /* We deleted the destination, so must force the error to be EIO */
5430 if ((retval != 0) && (pre_delete != 0))
5438 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5439 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5440 * to expand file specification. Allows for a single default file
5441 * specification and a simple mask of options. If outbuf is non-NULL,
5442 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5443 * the resultant file specification is placed. If outbuf is NULL, the
5444 * resultant file specification is placed into a static buffer.
5445 * The third argument, if non-NULL, is taken to be a default file
5446 * specification string. The fourth argument is unused at present.
5447 * rmesexpand() returns the address of the resultant string if
5448 * successful, and NULL on error.
5450 * New functionality for previously unused opts value:
5451 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5452 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5453 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5454 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5456 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5460 (const char *filespec,
5462 const char *defspec,
5468 const char * in_spec;
5470 const char * def_spec;
5471 char * vmsfspec, *vmsdefspec;
5475 struct FAB myfab = cc$rms_fab;
5476 rms_setup_nam(mynam);
5478 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5481 /* temp hack until UTF8 is actually implemented */
5482 if (fs_utf8 != NULL)
5485 if (!filespec || !*filespec) {
5486 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5496 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5497 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5498 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5500 /* If this is a UNIX file spec, convert it to VMS */
5501 sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5502 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5503 &e_len, &vs_spec, &vs_len);
5508 vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5509 if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5510 ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5511 if (ret_spec == NULL) {
5512 PerlMem_free(vmsfspec);
5515 in_spec = (const char *)vmsfspec;
5517 /* Unless we are forcing to VMS format, a UNIX input means
5518 * UNIX output, and that requires long names to be used
5520 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5521 #if defined(NAML$C_MAXRSS)
5522 opts |= PERL_RMSEXPAND_M_LONG;
5532 rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5533 rms_bind_fab_nam(myfab, mynam);
5535 /* Process the default file specification if present */
5537 if (defspec && *defspec) {
5539 t_isunix = is_unix_filespec(defspec);
5541 vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5542 if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5543 ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5545 if (ret_spec == NULL) {
5546 /* Clean up and bail */
5547 PerlMem_free(vmsdefspec);
5548 if (vmsfspec != NULL)
5549 PerlMem_free(vmsfspec);
5552 def_spec = (const char *)vmsdefspec;
5554 rms_set_dna(myfab, mynam,
5555 (char *)def_spec, strlen(def_spec)); /* cast ok */
5558 /* Now we need the expansion buffers */
5559 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
5560 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5561 #if defined(NAML$C_MAXRSS)
5562 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
5563 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5565 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5567 /* If a NAML block is used RMS always writes to the long and short
5568 * addresses unless you suppress the short name.
5570 #if defined(NAML$C_MAXRSS)
5571 outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
5572 if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5574 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5576 #ifdef NAM$M_NO_SHORT_UPCASE
5577 if (decc_efs_case_preserve)
5578 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5581 /* We may not want to follow symbolic links */
5582 #ifdef NAML$M_OPEN_SPECIAL
5583 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5584 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5587 /* First attempt to parse as an existing file */
5588 retsts = sys$parse(&myfab,0,0);
5589 if (!(retsts & STS$K_SUCCESS)) {
5591 /* Could not find the file, try as syntax only if error is not fatal */
5592 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5593 if (retsts == RMS$_DNF ||
5594 retsts == RMS$_DIR ||
5595 retsts == RMS$_DEV ||
5596 retsts == RMS$_PRV) {
5597 retsts = sys$parse(&myfab,0,0);
5598 if (retsts & STS$K_SUCCESS) goto int_expanded;
5601 /* Still could not parse the file specification */
5602 /*----------------------------------------------*/
5603 sts = rms_free_search_context(&myfab); /* Free search context */
5604 if (vmsdefspec != NULL)
5605 PerlMem_free(vmsdefspec);
5606 if (vmsfspec != NULL)
5607 PerlMem_free(vmsfspec);
5608 if (outbufl != NULL)
5609 PerlMem_free(outbufl);
5613 set_vaxc_errno(retsts);
5614 if (retsts == RMS$_PRV) set_errno(EACCES);
5615 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5616 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5617 else set_errno(EVMSERR);
5620 retsts = sys$search(&myfab,0,0);
5621 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5622 sts = rms_free_search_context(&myfab); /* Free search context */
5623 if (vmsdefspec != NULL)
5624 PerlMem_free(vmsdefspec);
5625 if (vmsfspec != NULL)
5626 PerlMem_free(vmsfspec);
5627 if (outbufl != NULL)
5628 PerlMem_free(outbufl);
5632 set_vaxc_errno(retsts);
5633 if (retsts == RMS$_PRV) set_errno(EACCES);
5634 else set_errno(EVMSERR);
5638 /* If the input filespec contained any lowercase characters,
5639 * downcase the result for compatibility with Unix-minded code. */
5641 if (!decc_efs_case_preserve) {
5643 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5644 if (islower(*tbuf)) { haslower = 1; break; }
5647 /* Is a long or a short name expected */
5648 /*------------------------------------*/
5650 #if defined(NAML$C_MAXRSS)
5651 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5652 if (rms_nam_rsll(mynam)) {
5654 speclen = rms_nam_rsll(mynam);
5657 spec_buf = esal; /* Not esa */
5658 speclen = rms_nam_esll(mynam);
5663 if (rms_nam_rsl(mynam)) {
5665 speclen = rms_nam_rsl(mynam);
5668 spec_buf = esa; /* Not esal */
5669 speclen = rms_nam_esl(mynam);
5671 #if defined(NAML$C_MAXRSS)
5674 spec_buf[speclen] = '\0';
5676 /* Trim off null fields added by $PARSE
5677 * If type > 1 char, must have been specified in original or default spec
5678 * (not true for version; $SEARCH may have added version of existing file).
5680 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5681 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5682 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5683 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5686 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5687 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5689 if (trimver || trimtype) {
5690 if (defspec && *defspec) {
5691 char *defesal = NULL;
5692 char *defesa = NULL;
5693 defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5694 if (defesa != NULL) {
5695 struct FAB deffab = cc$rms_fab;
5696 #if defined(NAML$C_MAXRSS)
5697 defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5698 if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5700 rms_setup_nam(defnam);
5702 rms_bind_fab_nam(deffab, defnam);
5706 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5708 /* RMS needs the esa/esal as a work area if wildcards are involved */
5709 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5711 rms_clear_nam_nop(defnam);
5712 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5713 #ifdef NAM$M_NO_SHORT_UPCASE
5714 if (decc_efs_case_preserve)
5715 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5717 #ifdef NAML$M_OPEN_SPECIAL
5718 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5719 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5721 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5723 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5726 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5729 if (defesal != NULL)
5730 PerlMem_free(defesal);
5731 PerlMem_free(defesa);
5733 _ckvmssts_noperl(SS$_INSFMEM);
5737 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5738 if (*(rms_nam_verl(mynam)) != '\"')
5739 speclen = rms_nam_verl(mynam) - spec_buf;
5742 if (*(rms_nam_ver(mynam)) != '\"')
5743 speclen = rms_nam_ver(mynam) - spec_buf;
5747 /* If we didn't already trim version, copy down */
5748 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5749 if (speclen > rms_nam_verl(mynam) - spec_buf)
5751 (rms_nam_typel(mynam),
5752 rms_nam_verl(mynam),
5753 speclen - (rms_nam_verl(mynam) - spec_buf));
5754 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5757 if (speclen > rms_nam_ver(mynam) - spec_buf)
5759 (rms_nam_type(mynam),
5761 speclen - (rms_nam_ver(mynam) - spec_buf));
5762 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5767 /* Done with these copies of the input files */
5768 /*-------------------------------------------*/
5769 if (vmsfspec != NULL)
5770 PerlMem_free(vmsfspec);
5771 if (vmsdefspec != NULL)
5772 PerlMem_free(vmsdefspec);
5774 /* If we just had a directory spec on input, $PARSE "helpfully"
5775 * adds an empty name and type for us */
5776 #if defined(NAML$C_MAXRSS)
5777 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5778 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5779 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5780 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5781 speclen = rms_nam_namel(mynam) - spec_buf;
5786 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5787 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5788 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5789 speclen = rms_nam_name(mynam) - spec_buf;
5792 /* Posix format specifications must have matching quotes */
5793 if (speclen < (VMS_MAXRSS - 1)) {
5794 if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5795 if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5796 spec_buf[speclen] = '\"';
5801 spec_buf[speclen] = '\0';
5802 if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5804 /* Have we been working with an expanded, but not resultant, spec? */
5805 /* Also, convert back to Unix syntax if necessary. */
5809 #if defined(NAML$C_MAXRSS)
5810 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5811 rsl = rms_nam_rsll(mynam);
5815 rsl = rms_nam_rsl(mynam);
5818 /* rsl is not present, it means that spec_buf is either */
5819 /* esa or esal, and needs to be copied to outbuf */
5820 /* convert to Unix if desired */
5822 ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5824 /* VMS file specs are not in UTF-8 */
5825 if (fs_utf8 != NULL)
5827 my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5832 /* Now spec_buf is either outbuf or outbufl */
5833 /* We need the result into outbuf */
5835 /* If we need this in UNIX, then we need another buffer */
5836 /* to keep things in order */
5838 char * new_src = NULL;
5839 if (spec_buf == outbuf) {
5840 new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
5841 my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5845 ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5847 PerlMem_free(new_src);
5850 /* VMS file specs are not in UTF-8 */
5851 if (fs_utf8 != NULL)
5854 /* Copy the buffer if needed */
5855 if (outbuf != spec_buf)
5856 my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5862 /* Need to clean up the search context */
5863 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5864 sts = rms_free_search_context(&myfab); /* Free search context */
5866 /* Clean up the extra buffers */
5870 if (outbufl != NULL)
5871 PerlMem_free(outbufl);
5873 /* Return the result */
5877 /* Common simple case - Expand an already VMS spec */
5879 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5880 opts |= PERL_RMSEXPAND_M_VMS_IN;
5881 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5884 /* Common simple case - Expand to a VMS spec */
5886 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5887 opts |= PERL_RMSEXPAND_M_VMS;
5888 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5892 /* Entry point used by perl routines */
5895 (pTHX_ const char *filespec,
5898 const char *defspec,
5903 static char __rmsexpand_retbuf[VMS_MAXRSS];
5904 char * expanded, *ret_spec, *ret_buf;
5908 if (ret_buf == NULL) {
5910 Newx(expanded, VMS_MAXRSS, char);
5911 if (expanded == NULL)
5912 _ckvmssts(SS$_INSFMEM);
5915 ret_buf = __rmsexpand_retbuf;
5920 ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5921 opts, fs_utf8, dfs_utf8);
5923 if (ret_spec == NULL) {
5924 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5932 /* External entry points */
5934 Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5936 return do_rmsexpand(spec, buf, 0, def, opt, NULL, NULL);
5940 Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5942 return do_rmsexpand(spec, buf, 1, def, opt, NULL, NULL);
5946 Perl_rmsexpand_utf8(pTHX_ const char *spec, char *buf, const char *def,
5947 unsigned opt, int * fs_utf8, int * dfs_utf8)
5949 return do_rmsexpand(spec, buf, 0, def, opt, fs_utf8, dfs_utf8);
5953 Perl_rmsexpand_utf8_ts(pTHX_ const char *spec, char *buf, const char *def,
5954 unsigned opt, int * fs_utf8, int * dfs_utf8)
5956 return do_rmsexpand(spec, buf, 1, def, opt, fs_utf8, dfs_utf8);
5961 ** The following routines are provided to make life easier when
5962 ** converting among VMS-style and Unix-style directory specifications.
5963 ** All will take input specifications in either VMS or Unix syntax. On
5964 ** failure, all return NULL. If successful, the routines listed below
5965 ** return a pointer to a buffer containing the appropriately
5966 ** reformatted spec (and, therefore, subsequent calls to that routine
5967 ** will clobber the result), while the routines of the same names with
5968 ** a _ts suffix appended will return a pointer to a mallocd string
5969 ** containing the appropriately reformatted spec.
5970 ** In all cases, only explicit syntax is altered; no check is made that
5971 ** the resulting string is valid or that the directory in question
5974 ** fileify_dirspec() - convert a directory spec into the name of the
5975 ** directory file (i.e. what you can stat() to see if it's a dir).
5976 ** The style (VMS or Unix) of the result is the same as the style
5977 ** of the parameter passed in.
5978 ** pathify_dirspec() - convert a directory spec into a path (i.e.
5979 ** what you prepend to a filename to indicate what directory it's in).
5980 ** The style (VMS or Unix) of the result is the same as the style
5981 ** of the parameter passed in.
5982 ** tounixpath() - convert a directory spec into a Unix-style path.
5983 ** tovmspath() - convert a directory spec into a VMS-style path.
5984 ** tounixspec() - convert any file spec into a Unix-style file spec.
5985 ** tovmsspec() - convert any file spec into a VMS-style spec.
5986 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5988 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
5989 ** Permission is given to distribute this code as part of the Perl
5990 ** standard distribution under the terms of the GNU General Public
5991 ** License or the Perl Artistic License. Copies of each may be
5992 ** found in the Perl standard distribution.
5995 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5997 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5999 unsigned long int dirlen, retlen, hasfilename = 0;
6000 char *cp1, *cp2, *lastdir;
6001 char *trndir, *vmsdir;
6002 unsigned short int trnlnm_iter_count;
6004 if (utf8_fl != NULL)
6007 if (!dir || !*dir) {
6008 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6010 dirlen = strlen(dir);
6011 while (dirlen && dir[dirlen-1] == '/') --dirlen;
6012 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6013 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6020 if (dirlen > (VMS_MAXRSS - 1)) {
6021 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6024 trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
6025 if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6026 if (!strpbrk(dir+1,"/]>:") &&
6027 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6028 strcpy(trndir,*dir == '/' ? dir + 1: dir);
6029 trnlnm_iter_count = 0;
6030 while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6031 trnlnm_iter_count++;
6032 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6034 dirlen = strlen(trndir);
6037 memcpy(trndir, dir, dirlen);
6038 trndir[dirlen] = '\0';
6041 /* At this point we are done with *dir and use *trndir which is a
6042 * copy that can be modified. *dir must not be modified.
6045 /* If we were handed a rooted logical name or spec, treat it like a
6046 * simple directory, so that
6047 * $ Define myroot dev:[dir.]
6048 * ... do_fileify_dirspec("myroot",buf,1) ...
6049 * does something useful.
6051 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6052 trndir[--dirlen] = '\0';
6053 trndir[dirlen-1] = ']';
6055 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6056 trndir[--dirlen] = '\0';
6057 trndir[dirlen-1] = '>';
6060 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6061 /* If we've got an explicit filename, we can just shuffle the string. */
6062 if (*(cp1+1)) hasfilename = 1;
6063 /* Similarly, we can just back up a level if we've got multiple levels
6064 of explicit directories in a VMS spec which ends with directories. */
6066 for (cp2 = cp1; cp2 > trndir; cp2--) {
6068 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6069 /* fix-me, can not scan EFS file specs backward like this */
6070 *cp2 = *cp1; *cp1 = '\0';
6075 if (*cp2 == '[' || *cp2 == '<') break;
6080 vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
6081 if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6082 cp1 = strpbrk(trndir,"]:>");
6083 if (cp1 && *(cp1+1) == ':') /* DECNet node spec with :: */
6084 cp1 = strpbrk(cp1+2,"]:>");
6086 if (hasfilename || !cp1) { /* filename present or not VMS */
6088 if (trndir[0] == '.') {
6089 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6090 PerlMem_free(trndir);
6091 PerlMem_free(vmsdir);
6092 return int_fileify_dirspec("[]", buf, NULL);
6094 else if (trndir[1] == '.' &&
6095 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6096 PerlMem_free(trndir);
6097 PerlMem_free(vmsdir);
6098 return int_fileify_dirspec("[-]", buf, NULL);
6101 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
6102 dirlen -= 1; /* to last element */
6103 lastdir = strrchr(trndir,'/');
6105 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6106 /* If we have "/." or "/..", VMSify it and let the VMS code
6107 * below expand it, rather than repeating the code to handle
6108 * relative components of a filespec here */
6110 if (*(cp1+2) == '.') cp1++;
6111 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6113 if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6114 PerlMem_free(trndir);
6115 PerlMem_free(vmsdir);
6118 if (strchr(vmsdir,'/') != NULL) {
6119 /* If int_tovmsspec() returned it, it must have VMS syntax
6120 * delimiters in it, so it's a mixed VMS/Unix spec. We take
6121 * the time to check this here only so we avoid a recursion
6122 * loop; otherwise, gigo.
6124 PerlMem_free(trndir);
6125 PerlMem_free(vmsdir);
6126 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
6129 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6130 PerlMem_free(trndir);
6131 PerlMem_free(vmsdir);
6134 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6135 PerlMem_free(trndir);
6136 PerlMem_free(vmsdir);
6140 } while ((cp1 = strstr(cp1,"/.")) != NULL);
6141 lastdir = strrchr(trndir,'/');
6143 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6145 /* Ditto for specs that end in an MFD -- let the VMS code
6146 * figure out whether it's a real device or a rooted logical. */
6148 /* This should not happen any more. Allowing the fake /000000
6149 * in a UNIX pathname causes all sorts of problems when trying
6150 * to run in UNIX emulation. So the VMS to UNIX conversions
6151 * now remove the fake /000000 directories.
6154 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6155 if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6156 PerlMem_free(trndir);
6157 PerlMem_free(vmsdir);
6160 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6161 PerlMem_free(trndir);
6162 PerlMem_free(vmsdir);
6165 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6166 PerlMem_free(trndir);
6167 PerlMem_free(vmsdir);
6172 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6173 !(lastdir = cp1 = strrchr(trndir,']')) &&
6174 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6176 cp2 = strrchr(cp1,'.');
6178 int e_len, vs_len = 0;
6181 cp3 = strchr(cp2,';');
6182 e_len = strlen(cp2);
6184 vs_len = strlen(cp3);
6185 e_len = e_len - vs_len;
6187 is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6189 if (!decc_efs_charset) {
6190 /* If this is not EFS, then not a directory */
6191 PerlMem_free(trndir);
6192 PerlMem_free(vmsdir);
6194 set_vaxc_errno(RMS$_DIR);
6198 /* Ok, here we have an issue, technically if a .dir shows */
6199 /* from inside a directory, then we should treat it as */
6200 /* xxx^.dir.dir. But we do not have that context at this */
6201 /* point unless this is totally restructured, so we remove */
6202 /* The .dir for now, and fix this better later */
6203 dirlen = cp2 - trndir;
6205 if (decc_efs_charset && !strchr(trndir,'/')) {
6206 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6207 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6209 for (; cp4 > cp1; cp4--) {
6211 if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6212 memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6223 retlen = dirlen + 6;
6224 memcpy(buf, trndir, dirlen);
6227 /* We've picked up everything up to the directory file name.
6228 Now just add the type and version, and we're set. */
6229 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6233 if (!decc_filename_unix_no_version)
6235 PerlMem_free(trndir);
6236 PerlMem_free(vmsdir);
6239 else { /* VMS-style directory spec */
6241 char *esa, *esal, term, *cp;
6244 unsigned long int cmplen, haslower = 0;
6245 struct FAB dirfab = cc$rms_fab;
6246 rms_setup_nam(savnam);
6247 rms_setup_nam(dirnam);
6249 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
6250 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6252 #if defined(NAML$C_MAXRSS)
6253 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
6254 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6256 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6257 rms_bind_fab_nam(dirfab, dirnam);
6258 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6259 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6260 #ifdef NAM$M_NO_SHORT_UPCASE
6261 if (decc_efs_case_preserve)
6262 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6265 for (cp = trndir; *cp; cp++)
6266 if (islower(*cp)) { haslower = 1; break; }
6267 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6268 if ((dirfab.fab$l_sts == RMS$_DIR) ||
6269 (dirfab.fab$l_sts == RMS$_DNF) ||
6270 (dirfab.fab$l_sts == RMS$_PRV)) {
6271 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6272 sts = sys$parse(&dirfab);
6278 PerlMem_free(trndir);
6279 PerlMem_free(vmsdir);
6281 set_vaxc_errno(dirfab.fab$l_sts);
6287 /* Does the file really exist? */
6288 if (sys$search(&dirfab)& STS$K_SUCCESS) {
6289 /* Yes; fake the fnb bits so we'll check type below */
6290 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6292 else { /* No; just work with potential name */
6293 if (dirfab.fab$l_sts == RMS$_FNF
6294 || dirfab.fab$l_sts == RMS$_DNF
6295 || dirfab.fab$l_sts == RMS$_FND)
6299 fab_sts = dirfab.fab$l_sts;
6300 sts = rms_free_search_context(&dirfab);
6304 PerlMem_free(trndir);
6305 PerlMem_free(vmsdir);
6306 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
6312 /* Make sure we are using the right buffer */
6313 #if defined(NAML$C_MAXRSS)
6316 my_esa_len = rms_nam_esll(dirnam);
6320 my_esa_len = rms_nam_esl(dirnam);
6321 #if defined(NAML$C_MAXRSS)
6324 my_esa[my_esa_len] = '\0';
6325 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6326 cp1 = strchr(my_esa,']');
6327 if (!cp1) cp1 = strchr(my_esa,'>');
6328 if (cp1) { /* Should always be true */
6329 my_esa_len -= cp1 - my_esa - 1;
6330 memmove(my_esa, cp1 + 1, my_esa_len);
6333 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6334 /* Yep; check version while we're at it, if it's there. */
6335 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6336 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6337 /* Something other than .DIR[;1]. Bzzt. */
6338 sts = rms_free_search_context(&dirfab);
6342 PerlMem_free(trndir);
6343 PerlMem_free(vmsdir);
6345 set_vaxc_errno(RMS$_DIR);
6350 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6351 /* They provided at least the name; we added the type, if necessary, */
6352 my_strlcpy(buf, my_esa, VMS_MAXRSS);
6353 sts = rms_free_search_context(&dirfab);
6354 PerlMem_free(trndir);
6358 PerlMem_free(vmsdir);
6361 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6362 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6366 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6367 if (cp1 == NULL) { /* should never happen */
6368 sts = rms_free_search_context(&dirfab);
6369 PerlMem_free(trndir);
6373 PerlMem_free(vmsdir);
6378 retlen = strlen(my_esa);
6379 cp1 = strrchr(my_esa,'.');
6380 /* ODS-5 directory specifications can have extra "." in them. */
6381 /* Fix-me, can not scan EFS file specifications backwards */
6382 while (cp1 != NULL) {
6383 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6387 while ((cp1 > my_esa) && (*cp1 != '.'))
6394 if ((cp1) != NULL) {
6395 /* There's more than one directory in the path. Just roll back. */
6397 my_strlcpy(buf, my_esa, VMS_MAXRSS);
6400 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6401 /* Go back and expand rooted logical name */
6402 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6403 #ifdef NAM$M_NO_SHORT_UPCASE
6404 if (decc_efs_case_preserve)
6405 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6407 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6408 sts = rms_free_search_context(&dirfab);
6412 PerlMem_free(trndir);
6413 PerlMem_free(vmsdir);
6415 set_vaxc_errno(dirfab.fab$l_sts);
6419 /* This changes the length of the string of course */
6421 my_esa_len = rms_nam_esll(dirnam);
6423 my_esa_len = rms_nam_esl(dirnam);
6426 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6427 cp1 = strstr(my_esa,"][");
6428 if (!cp1) cp1 = strstr(my_esa,"]<");
6429 dirlen = cp1 - my_esa;
6430 memcpy(buf, my_esa, dirlen);
6431 if (!strncmp(cp1+2,"000000]",7)) {
6432 buf[dirlen-1] = '\0';
6433 /* fix-me Not full ODS-5, just extra dots in directories for now */
6434 cp1 = buf + dirlen - 1;
6440 if (*(cp1-1) != '^')
6445 if (*cp1 == '.') *cp1 = ']';
6447 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6448 memmove(cp1+1,"000000]",7);
6452 memmove(buf+dirlen, cp1+2, retlen-dirlen);
6454 /* Convert last '.' to ']' */
6456 while (*cp != '[') {
6459 /* Do not trip on extra dots in ODS-5 directories */
6460 if ((cp1 == buf) || (*(cp1-1) != '^'))
6464 if (*cp1 == '.') *cp1 = ']';
6466 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6467 memmove(cp1+1,"000000]",7);
6471 else { /* This is a top-level dir. Add the MFD to the path. */
6472 cp1 = strrchr(my_esa, ':');
6474 memmove(buf, my_esa, cp1 - my_esa + 1);
6475 memmove(buf + (cp1 - my_esa) + 1, "[000000]", 8);
6476 memmove(buf + (cp1 - my_esa) + 9, cp1 + 2, retlen - (cp1 - my_esa + 2));
6477 buf[retlen + 7] = '\0'; /* We've inserted '000000]' */
6480 sts = rms_free_search_context(&dirfab);
6481 /* We've set up the string up through the filename. Add the
6482 type and version, and we're done. */
6483 strcat(buf,".DIR;1");
6485 /* $PARSE may have upcased filespec, so convert output to lower
6486 * case if input contained any lowercase characters. */
6487 if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6488 PerlMem_free(trndir);
6492 PerlMem_free(vmsdir);
6495 } /* end of int_fileify_dirspec() */
6498 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6500 mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6502 static char __fileify_retbuf[VMS_MAXRSS];
6503 char * fileified, *ret_spec, *ret_buf;
6507 if (ret_buf == NULL) {
6509 Newx(fileified, VMS_MAXRSS, char);
6510 if (fileified == NULL)
6511 _ckvmssts(SS$_INSFMEM);
6512 ret_buf = fileified;
6514 ret_buf = __fileify_retbuf;
6518 ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6520 if (ret_spec == NULL) {
6521 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6523 Safefree(fileified);
6527 } /* end of do_fileify_dirspec() */
6530 /* External entry points */
6532 Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6534 return do_fileify_dirspec(dir, buf, 0, NULL);
6538 Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6540 return do_fileify_dirspec(dir, buf, 1, NULL);
6544 Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6546 return do_fileify_dirspec(dir, buf, 0, utf8_fl);
6550 Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6552 return do_fileify_dirspec(dir, buf, 1, utf8_fl);
6556 int_pathify_dirspec_simple(const char * dir, char * buf,
6557 char * v_spec, int v_len, char * r_spec, int r_len,
6558 char * d_spec, int d_len, char * n_spec, int n_len,
6559 char * e_spec, int e_len, char * vs_spec, int vs_len)
6562 /* VMS specification - Try to do this the simple way */
6563 if ((v_len + r_len > 0) || (d_len > 0)) {
6566 /* No name or extension component, already a directory */
6567 if ((n_len + e_len + vs_len) == 0) {
6572 /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6573 /* This results from catfile() being used instead of catdir() */
6574 /* So even though it should not work, we need to allow it */
6576 /* If this is .DIR;1 then do a simple conversion */
6577 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6578 if (is_dir || (e_len == 0) && (d_len > 0)) {
6580 len = v_len + r_len + d_len - 1;
6581 char dclose = d_spec[d_len - 1];
6582 memcpy(buf, dir, len);
6585 memcpy(&buf[len], n_spec, n_len);
6588 buf[len + 1] = '\0';
6593 else if (d_len > 0) {
6594 /* In the olden days, a directory needed to have a .DIR */
6595 /* extension to be a valid directory, but now it could */
6596 /* be a symbolic link */
6598 len = v_len + r_len + d_len - 1;
6599 char dclose = d_spec[d_len - 1];
6600 memcpy(buf, dir, len);
6603 memcpy(&buf[len], n_spec, n_len);
6606 if (decc_efs_charset) {
6608 && (toupper(e_spec[1]) == 'D')
6609 && (toupper(e_spec[2]) == 'I')
6610 && (toupper(e_spec[3]) == 'R')) {
6612 /* Corner case: directory spec with invalid version.
6613 * Valid would have followed is_dir path above.
6615 SETERRNO(ENOTDIR, RMS$_DIR);
6621 memcpy(&buf[len], e_spec, e_len);
6626 SETERRNO(ENOTDIR, RMS$_DIR);
6631 buf[len + 1] = '\0';
6636 set_vaxc_errno(RMS$_DIR);
6642 set_vaxc_errno(RMS$_DIR);
6648 /* Internal routine to make sure or convert a directory to be in a */
6649 /* path specification. No utf8 flag because it is not changed or used */
6651 int_pathify_dirspec(const char *dir, char *buf)
6653 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6654 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6655 char * exp_spec, *ret_spec;
6657 unsigned short int trnlnm_iter_count;
6661 if (vms_debug_fileify) {
6663 fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6665 fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6668 /* We may need to lower case the result if we translated */
6669 /* a logical name or got the current working directory */
6672 if (!dir || !*dir) {
6674 set_vaxc_errno(SS$_BADPARAM);
6678 trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
6680 _ckvmssts_noperl(SS$_INSFMEM);
6682 /* If no directory specified use the current default */
6684 my_strlcpy(trndir, dir, VMS_MAXRSS);
6686 getcwd(trndir, VMS_MAXRSS - 1);
6690 /* now deal with bare names that could be logical names */
6691 trnlnm_iter_count = 0;
6692 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6693 && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6694 trnlnm_iter_count++;
6696 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6698 trnlen = strlen(trndir);
6700 /* Trap simple rooted lnms, and return lnm:[000000] */
6701 if (!strcmp(trndir+trnlen-2,".]")) {
6702 my_strlcpy(buf, dir, VMS_MAXRSS);
6703 strcat(buf, ":[000000]");
6704 PerlMem_free(trndir);
6706 if (vms_debug_fileify) {
6707 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6713 /* At this point we do not work with *dir, but the copy in *trndir */
6715 if (need_to_lower && !decc_efs_case_preserve) {
6716 /* Legacy mode, lower case the returned value */
6717 __mystrtolower(trndir);
6721 /* Some special cases, '..', '.' */
6723 if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6724 /* Force UNIX filespec */
6728 /* Is this Unix or VMS format? */
6729 sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6730 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6731 &e_len, &vs_spec, &vs_len);
6734 /* Just a filename? */
6735 if ((v_len + r_len + d_len) == 0) {
6737 /* Now we have a problem, this could be Unix or VMS */
6738 /* We have to guess. .DIR usually means VMS */
6740 /* In UNIX report mode, the .DIR extension is removed */
6741 /* if one shows up, it is for a non-directory or a directory */
6742 /* in EFS charset mode */
6744 /* So if we are in Unix report mode, assume that this */
6745 /* is a relative Unix directory specification */
6748 if (!decc_filename_unix_report && decc_efs_charset) {
6750 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6753 /* Traditional mode, assume .DIR is directory */
6756 memcpy(&buf[2], n_spec, n_len);
6757 buf[n_len + 2] = ']';
6758 buf[n_len + 3] = '\0';
6759 PerlMem_free(trndir);
6760 if (vms_debug_fileify) {
6762 "int_pathify_dirspec: buf = %s\n",
6772 ret_spec = int_pathify_dirspec_simple(trndir, buf,
6773 v_spec, v_len, r_spec, r_len,
6774 d_spec, d_len, n_spec, n_len,
6775 e_spec, e_len, vs_spec, vs_len);
6777 if (ret_spec != NULL) {
6778 PerlMem_free(trndir);
6779 if (vms_debug_fileify) {
6781 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6786 /* Simple way did not work, which means that a logical name */
6787 /* was present for the directory specification. */
6788 /* Need to use an rmsexpand variant to decode it completely */
6789 exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
6790 if (exp_spec == NULL)
6791 _ckvmssts_noperl(SS$_INSFMEM);
6793 ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6794 if (ret_spec != NULL) {
6795 sts = vms_split_path(exp_spec, &v_spec, &v_len,
6796 &r_spec, &r_len, &d_spec, &d_len,
6797 &n_spec, &n_len, &e_spec,
6798 &e_len, &vs_spec, &vs_len);
6800 ret_spec = int_pathify_dirspec_simple(
6801 exp_spec, buf, v_spec, v_len, r_spec, r_len,
6802 d_spec, d_len, n_spec, n_len,
6803 e_spec, e_len, vs_spec, vs_len);
6805 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6806 /* Legacy mode, lower case the returned value */
6807 __mystrtolower(ret_spec);
6810 set_vaxc_errno(RMS$_DIR);
6815 PerlMem_free(exp_spec);
6816 PerlMem_free(trndir);
6817 if (vms_debug_fileify) {
6818 if (ret_spec == NULL)
6819 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6822 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6827 /* Unix specification, Could be trivial conversion, */
6828 /* but have to deal with trailing '.dir' or extra '.' */
6833 STRLEN dir_len = strlen(trndir);
6835 lastslash = strrchr(trndir, '/');
6836 if (lastslash == NULL)
6843 /* '..' or '.' are valid directory components */
6845 if (lastslash[0] == '.') {
6846 if (lastslash[1] == '\0') {
6848 } else if (lastslash[1] == '.') {
6849 if (lastslash[2] == '\0') {
6852 /* And finally allow '...' */
6853 if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6861 lastdot = strrchr(lastslash, '.');
6863 if (lastdot != NULL) {
6865 /* '.dir' is discarded, and any other '.' is invalid */
6866 e_len = strlen(lastdot);
6868 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6871 dir_len = dir_len - 4;
6875 my_strlcpy(buf, trndir, VMS_MAXRSS);
6876 if (buf[dir_len - 1] != '/') {
6878 buf[dir_len + 1] = '\0';
6881 /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6882 if (!decc_efs_charset) {
6885 if (str[0] == '.') {
6888 while ((dots[cnt] == '.') && (cnt < 3))
6891 if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6897 for (; *str; ++str) {
6898 while (*str == '/') {
6904 /* Have to skip up to three dots which could be */
6905 /* directories, 3 dots being a VMS extension for Perl */
6908 while ((dots[cnt] == '.') && (cnt < 3)) {
6911 if (dots[cnt] == '\0')
6913 if ((cnt > 1) && (dots[cnt] != '/')) {
6919 /* too many dots? */
6920 if ((cnt == 0) || (cnt > 3)) {
6924 if (!dir_start && (*str == '.')) {
6929 PerlMem_free(trndir);
6931 if (vms_debug_fileify) {
6932 if (ret_spec == NULL)
6933 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6936 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6942 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6944 mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6946 static char __pathify_retbuf[VMS_MAXRSS];
6947 char * pathified, *ret_spec, *ret_buf;
6951 if (ret_buf == NULL) {
6953 Newx(pathified, VMS_MAXRSS, char);
6954 if (pathified == NULL)
6955 _ckvmssts(SS$_INSFMEM);
6956 ret_buf = pathified;
6958 ret_buf = __pathify_retbuf;
6962 ret_spec = int_pathify_dirspec(dir, ret_buf);
6964 if (ret_spec == NULL) {
6965 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6967 Safefree(pathified);
6972 } /* end of do_pathify_dirspec() */
6975 /* External entry points */
6977 Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6979 return do_pathify_dirspec(dir, buf, 0, NULL);
6983 Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6985 return do_pathify_dirspec(dir, buf, 1, NULL);
6989 Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6991 return do_pathify_dirspec(dir, buf, 0, utf8_fl);
6995 Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6997 return do_pathify_dirspec(dir, buf, 1, utf8_fl);
7000 /* Internal tounixspec routine that does not use a thread context */
7001 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7003 int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7005 char *dirend, *cp1, *cp3, *tmp;
7008 unsigned short int trnlnm_iter_count;
7009 int cmp_rslt, outchars_added;
7010 if (utf8_fl != NULL)
7013 if (vms_debug_fileify) {
7015 fprintf(stderr, "int_tounixspec: spec = NULL\n");
7017 fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7023 set_vaxc_errno(SS$_BADPARAM);
7026 if (strlen(spec) > (VMS_MAXRSS-1)) {
7028 set_vaxc_errno(SS$_BUFFEROVF);
7032 /* New VMS specific format needs translation
7033 * glob passes filenames with trailing '\n' and expects this preserved.
7035 if (decc_posix_compliant_pathnames) {
7036 if (strncmp(spec, "\"^UP^", 5) == 0) {
7042 tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
7043 if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7044 tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
7046 if (tunix[tunix_len - 1] == '\n') {
7047 tunix[tunix_len - 1] = '\"';
7048 tunix[tunix_len] = '\0';
7052 uspec = decc$translate_vms(tunix);
7053 PerlMem_free(tunix);
7054 if ((int)uspec > 0) {
7055 my_strlcpy(rslt, uspec, VMS_MAXRSS);
7060 /* If we can not translate it, makemaker wants as-is */
7061 my_strlcpy(rslt, spec, VMS_MAXRSS);
7068 cmp_rslt = 0; /* Presume VMS */
7069 cp1 = strchr(spec, '/');
7073 /* Look for EFS ^/ */
7074 if (decc_efs_charset) {
7075 while (cp1 != NULL) {
7078 /* Found illegal VMS, assume UNIX */
7083 cp1 = strchr(cp1, '/');
7087 /* Look for "." and ".." */
7088 if (decc_filename_unix_report) {
7089 if (spec[0] == '.') {
7090 if ((spec[1] == '\0') || (spec[1] == '\n')) {
7094 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7104 /* This is already UNIX or at least nothing VMS understands,
7105 * so all we can reasonably do is unescape extended chars.
7109 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7110 cp1 += outchars_added;
7113 if (vms_debug_fileify) {
7114 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7119 dirend = strrchr(spec,']');
7120 if (dirend == NULL) dirend = strrchr(spec,'>');
7121 if (dirend == NULL) dirend = strchr(spec,':');
7122 if (dirend == NULL) {
7124 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7125 cp1 += outchars_added;
7128 if (vms_debug_fileify) {
7129 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7134 /* Special case 1 - sys$posix_root = / */
7135 if (!decc_disable_posix_root) {
7136 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7143 /* Special case 2 - Convert NLA0: to /dev/null */
7144 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7145 if (cmp_rslt == 0) {
7146 strcpy(rslt, "/dev/null");
7149 if (spec[6] != '\0') {
7156 /* Also handle special case "SYS$SCRATCH:" */
7157 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7158 tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
7159 if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7160 if (cmp_rslt == 0) {
7163 islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7165 strcpy(rslt, "/tmp");
7168 if (spec[12] != '\0') {
7176 if (*cp2 != '[' && *cp2 != '<') {
7179 else { /* the VMS spec begins with directories */
7181 if (*cp2 == ']' || *cp2 == '>') {
7185 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7186 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7188 if (vms_debug_fileify) {
7189 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7193 trnlnm_iter_count = 0;
7196 while (*cp3 != ':' && *cp3) cp3++;
7198 if (strchr(cp3,']') != NULL) break;
7199 trnlnm_iter_count++;
7200 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7201 } while (vmstrnenv(tmp,tmp,0,fildev,0));
7206 *(cp1++) = *(cp3++);
7207 if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7209 set_errno(ENAMETOOLONG);
7210 set_vaxc_errno(SS$_BUFFEROVF);
7211 if (vms_debug_fileify) {
7212 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7214 return NULL; /* No room */
7219 if ((*cp2 == '^')) {
7220 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7221 cp1 += outchars_added;
7223 else if ( *cp2 == '.') {
7224 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7225 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7232 for (; cp2 <= dirend; cp2++) {
7233 if ((*cp2 == '^')) {
7234 /* EFS file escape -- unescape it. */
7235 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added) - 1;
7236 cp1 += outchars_added;
7238 else if (*cp2 == ':') {
7240 if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7242 else if (*cp2 == ']' || *cp2 == '>') {
7243 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7245 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7247 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7248 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7249 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7250 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7251 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7253 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7254 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7258 else if (*cp2 == '-') {
7259 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7260 while (*cp2 == '-') {
7262 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7264 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7265 /* filespecs like */
7266 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
7267 if (vms_debug_fileify) {
7268 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7273 else *(cp1++) = *cp2;
7275 else *(cp1++) = *cp2;
7277 /* Translate the rest of the filename. */
7281 /* Fixme - for compatibility with the CRTL we should be removing */
7282 /* spaces from the file specifications, but this may show that */
7283 /* some tests that were appearing to pass are not really passing */
7289 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7290 cp1 += outchars_added;
7293 if (decc_filename_unix_no_version) {
7294 /* Easy, drop the version */
7299 /* Punt - passing the version as a dot will probably */
7300 /* break perl in weird ways, but so did passing */
7301 /* through the ; as a version. Follow the CRTL and */
7302 /* hope for the best. */
7309 /* We will need to fix this properly later */
7310 /* As Perl may be installed on an ODS-5 volume, but not */
7311 /* have the EFS_CHARSET enabled, it still may encounter */
7312 /* filenames with extra dots in them, and a precedent got */
7313 /* set which allowed them to work, that we will uphold here */
7314 /* If extra dots are present in a name and no ^ is on them */
7315 /* VMS assumes that the first one is the extension delimiter */
7316 /* the rest have an implied ^. */
7318 /* this is also a conflict as the . is also a version */
7319 /* delimiter in VMS, */
7321 *(cp1++) = *(cp2++);
7325 /* This is an extension */
7326 if (decc_readdir_dropdotnotype) {
7328 if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7329 /* Drop the dot for the extension */
7337 *(cp1++) = *(cp2++);
7342 /* This still leaves /000000/ when working with a
7343 * VMS device root or concealed root.
7349 ulen = strlen(rslt);
7351 /* Get rid of "000000/ in rooted filespecs */
7353 zeros = strstr(rslt, "/000000/");
7354 if (zeros != NULL) {
7356 mlen = ulen - (zeros - rslt) - 7;
7357 memmove(zeros, &zeros[7], mlen);
7364 if (vms_debug_fileify) {
7365 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7369 } /* end of int_tounixspec() */
7372 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7374 mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7376 static char __tounixspec_retbuf[VMS_MAXRSS];
7377 char * unixspec, *ret_spec, *ret_buf;
7381 if (ret_buf == NULL) {
7383 Newx(unixspec, VMS_MAXRSS, char);
7384 if (unixspec == NULL)
7385 _ckvmssts(SS$_INSFMEM);
7388 ret_buf = __tounixspec_retbuf;
7392 ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7394 if (ret_spec == NULL) {
7395 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7402 } /* end of do_tounixspec() */
7404 /* External entry points */
7406 Perl_tounixspec(pTHX_ const char *spec, char *buf)
7408 return do_tounixspec(spec, buf, 0, NULL);
7412 Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7414 return do_tounixspec(spec,buf,1, NULL);
7418 Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7420 return do_tounixspec(spec,buf,0, utf8_fl);
7424 Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7426 return do_tounixspec(spec,buf,1, utf8_fl);
7430 This procedure is used to identify if a path is based in either
7431 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7432 it returns the OpenVMS format directory for it.
7434 It is expecting specifications of only '/' or '/xxxx/'
7436 If a posix root does not exist, or 'xxxx' is not a directory
7437 in the posix root, it returns a failure.
7439 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7441 It is used only internally by posix_to_vmsspec_hardway().
7445 posix_root_to_vms(char *vmspath, int vmspath_len,
7446 const char *unixpath, const int * utf8_fl)
7449 struct FAB myfab = cc$rms_fab;
7450 rms_setup_nam(mynam);
7451 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7452 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7453 char * esa, * esal, * rsa, * rsal;
7459 unixlen = strlen(unixpath);
7464 #if __CRTL_VER >= 80200000
7465 /* If not a posix spec already, convert it */
7466 if (decc_posix_compliant_pathnames) {
7467 if (strncmp(unixpath,"\"^UP^",5) != 0) {
7468 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7471 /* This is already a VMS specification, no conversion */
7473 my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7482 /* Check to see if this is under the POSIX root */
7483 if (decc_disable_posix_root) {
7487 /* Skip leading / */
7488 if (unixpath[0] == '/') {
7494 strcpy(vmspath,"SYS$POSIX_ROOT:");
7496 /* If this is only the / , or blank, then... */
7497 if (unixpath[0] == '\0') {
7498 /* by definition, this is the answer */
7502 /* Need to look up a directory */
7506 /* Copy and add '^' escape characters as needed */
7509 while (unixpath[i] != 0) {
7512 j += copy_expand_unix_filename_escape
7513 (&vmspath[j], &unixpath[i], &k, utf8_fl);
7517 path_len = strlen(vmspath);
7518 if (vmspath[path_len - 1] == '/')
7520 vmspath[path_len] = ']';
7522 vmspath[path_len] = '\0';
7525 vmspath[vmspath_len] = 0;
7526 if (unixpath[unixlen - 1] == '/')
7528 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7529 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7530 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7531 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7532 rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7533 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7534 rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7535 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7536 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7537 rms_bind_fab_nam(myfab, mynam);
7538 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7539 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7540 if (decc_efs_case_preserve)
7541 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7542 #ifdef NAML$M_OPEN_SPECIAL
7543 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7546 /* Set up the remaining naml fields */
7547 sts = sys$parse(&myfab);
7549 /* It failed! Try again as a UNIX filespec */
7558 /* get the Device ID and the FID */
7559 sts = sys$search(&myfab);
7561 /* These are no longer needed */
7566 /* on any failure, returned the POSIX ^UP^ filespec */
7571 specdsc.dsc$a_pointer = vmspath;
7572 specdsc.dsc$w_length = vmspath_len;
7574 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7575 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7576 sts = lib$fid_to_name
7577 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7579 /* on any failure, returned the POSIX ^UP^ filespec */
7581 /* This can happen if user does not have permission to read directories */
7582 if (strncmp(unixpath,"\"^UP^",5) != 0)
7583 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7585 my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7588 vmspath[specdsc.dsc$w_length] = 0;
7590 /* Are we expecting a directory? */
7591 if (dir_flag != 0) {
7597 i = specdsc.dsc$w_length - 1;
7601 /* Version must be '1' */
7602 if (vmspath[i--] != '1')
7604 /* Version delimiter is one of ".;" */
7605 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7608 if (vmspath[i--] != 'R')
7610 if (vmspath[i--] != 'I')
7612 if (vmspath[i--] != 'D')
7614 if (vmspath[i--] != '.')
7616 eptr = &vmspath[i+1];
7618 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7619 if (vmspath[i-1] != '^') {
7627 /* Get rid of 6 imaginary zero directory filename */
7628 vmspath[i+1] = '\0';
7632 if (vmspath[i] == '0')
7646 /* /dev/mumble needs to be handled special.
7647 /dev/null becomes NLA0:, And there is the potential for other stuff
7648 like /dev/tty which may need to be mapped to something.
7652 slash_dev_special_to_vms(const char *unixptr, char *vmspath, int vmspath_len)
7659 nextslash = strchr(unixptr, '/');
7660 len = strlen(unixptr);
7661 if (nextslash != NULL)
7662 len = nextslash - unixptr;
7663 cmp = strncmp("null", unixptr, 5);
7665 if (vmspath_len >= 6) {
7666 strcpy(vmspath, "_NLA0:");
7674 /* The built in routines do not understand perl's special needs, so
7675 doing a manual conversion from UNIX to VMS
7677 If the utf8_fl is not null and points to a non-zero value, then
7678 treat 8 bit characters as UTF-8.
7680 The sequence starting with '$(' and ending with ')' will be passed
7681 through with out interpretation instead of being escaped.
7685 posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath,
7686 int dir_flag, int * utf8_fl)
7690 const char *unixptr;
7691 const char *unixend;
7693 const char *lastslash;
7694 const char *lastdot;
7700 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7701 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7703 if (utf8_fl != NULL)
7709 /* Ignore leading "/" characters */
7710 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7713 unixlen = strlen(unixptr);
7715 /* Do nothing with blank paths */
7722 /* This could have a "^UP^ on the front */
7723 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7729 lastslash = strrchr(unixptr,'/');
7730 lastdot = strrchr(unixptr,'.');
7731 unixend = strrchr(unixptr,'\"');
7732 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7733 unixend = unixptr + unixlen;
7736 /* last dot is last dot or past end of string */
7737 if (lastdot == NULL)
7738 lastdot = unixptr + unixlen;
7740 /* if no directories, set last slash to beginning of string */
7741 if (lastslash == NULL) {
7742 lastslash = unixptr;
7745 /* Watch out for trailing "." after last slash, still a directory */
7746 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7747 lastslash = unixptr + unixlen;
7750 /* Watch out for trailing ".." after last slash, still a directory */
7751 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7752 lastslash = unixptr + unixlen;
7755 /* dots in directories are aways escaped */
7756 if (lastdot < lastslash)
7757 lastdot = unixptr + unixlen;
7760 /* if (unixptr < lastslash) then we are in a directory */
7767 /* Start with the UNIX path */
7768 if (*unixptr != '/') {
7769 /* relative paths */
7771 /* If allowing logical names on relative pathnames, then handle here */
7772 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7773 !decc_posix_compliant_pathnames) {
7779 /* Find the next slash */
7780 nextslash = strchr(unixptr,'/');
7782 esa = (char *)PerlMem_malloc(vmspath_len);
7783 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7785 trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7786 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7788 if (nextslash != NULL) {
7790 seg_len = nextslash - unixptr;
7791 memcpy(esa, unixptr, seg_len);
7795 seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7797 /* trnlnm(section) */
7798 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7801 /* Now fix up the directory */
7803 /* Split up the path to find the components */
7804 sts = vms_split_path
7822 /* A logical name must be a directory or the full
7823 specification. It is only a full specification if
7824 it is the only component */
7825 if ((unixptr[seg_len] == '\0') ||
7826 (unixptr[seg_len+1] == '\0')) {
7828 /* Is a directory being required? */
7829 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7830 /* Not a logical name */
7835 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7836 /* This must be a directory */
7837 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7838 vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7839 vmsptr[vmslen] = ':';
7841 vmsptr[vmslen] = '\0';
7849 /* must be dev/directory - ignore version */
7850 if ((n_len + e_len) != 0)
7853 /* transfer the volume */
7854 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7855 memcpy(vmsptr, v_spec, v_len);
7861 /* unroot the rooted directory */
7862 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7864 r_spec[r_len - 1] = ']';
7866 /* This should not be there, but nothing is perfect */
7868 cmp = strcmp(&r_spec[1], "000000.");
7878 memcpy(vmsptr, r_spec, r_len);
7884 /* Bring over the directory. */
7886 ((d_len + vmslen) < vmspath_len)) {
7888 d_spec[d_len - 1] = ']';
7890 cmp = strcmp(&d_spec[1], "000000.");
7901 /* Remove the redundant root */
7909 memcpy(vmsptr, d_spec, d_len);
7923 if (lastslash > unixptr) {
7926 /* skip leading ./ */
7928 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7934 /* Are we still in a directory? */
7935 if (unixptr <= lastslash) {
7940 /* if not backing up, then it is relative forward. */
7941 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7942 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7950 /* Perl wants an empty directory here to tell the difference
7951 * between a DCL command and a filename
7960 /* Handle two special files . and .. */
7961 if (unixptr[0] == '.') {
7962 if (&unixptr[1] == unixend) {
7969 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7980 else { /* Absolute PATH handling */
7984 /* Need to find out where root is */
7986 /* In theory, this procedure should never get an absolute POSIX pathname
7987 * that can not be found on the POSIX root.
7988 * In practice, that can not be relied on, and things will show up
7989 * here that are a VMS device name or concealed logical name instead.
7990 * So to make things work, this procedure must be tolerant.
7992 esa = (char *)PerlMem_malloc(vmspath_len);
7993 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7996 nextslash = strchr(&unixptr[1],'/');
7998 if (nextslash != NULL) {
8000 seg_len = nextslash - &unixptr[1];
8001 my_strlcpy(vmspath, unixptr, seg_len + 2);
8004 cmp = strncmp(vmspath, "dev", 4);
8006 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8007 if (sts == SS$_NORMAL)
8011 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8014 if ($VMS_STATUS_SUCCESS(sts)) {
8015 /* This is verified to be a real path */
8017 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8018 if ($VMS_STATUS_SUCCESS(sts)) {
8019 vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
8020 vmsptr = vmspath + vmslen;
8022 if (unixptr < lastslash) {
8031 cmp = strcmp(rptr,"000000.");
8036 } /* removing 6 zeros */
8037 } /* vmslen < 7, no 6 zeros possible */
8038 } /* Not in a directory */
8039 } /* Posix root found */
8041 /* No posix root, fall back to default directory */
8042 strcpy(vmspath, "SYS$DISK:[");
8043 vmsptr = &vmspath[10];
8045 if (unixptr > lastslash) {
8054 } /* end of verified real path handling */
8059 /* Ok, we have a device or a concealed root that is not in POSIX
8060 * or we have garbage. Make the best of it.
8063 /* Posix to VMS destroyed this, so copy it again */
8064 my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
8065 vmslen = strlen(vmspath); /* We know we're truncating. */
8066 vmsptr = &vmsptr[vmslen];
8069 /* Now do we need to add the fake 6 zero directory to it? */
8071 if ((*lastslash == '/') && (nextslash < lastslash)) {
8072 /* No there is another directory */
8079 /* now we have foo:bar or foo:[000000]bar to decide from */
8080 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8082 if (!islnm && !decc_posix_compliant_pathnames) {
8084 cmp = strncmp("bin", vmspath, 4);
8086 /* bin => SYS$SYSTEM: */
8087 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8090 /* tmp => SYS$SCRATCH: */
8091 cmp = strncmp("tmp", vmspath, 4);
8093 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8098 trnend = islnm ? islnm - 1 : 0;
8100 /* if this was a logical name, ']' or '>' must be present */
8101 /* if not a logical name, then assume a device and hope. */
8102 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8104 /* if log name and trailing '.' then rooted - treat as device */
8105 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8107 /* Fix me, if not a logical name, a device lookup should be
8108 * done to see if the device is file structured. If the device
8109 * is not file structured, the 6 zeros should not be put on.
8111 * As it is, perl is occasionally looking for dev:[000000]tty.
8112 * which looks a little strange.
8114 * Not that easy to detect as "/dev" may be file structured with
8115 * special device files.
8118 if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
8119 (&nextslash[1] == unixend)) {
8120 /* No real directory present */
8125 /* Put the device delimiter on */
8128 unixptr = nextslash;
8131 /* Start directory if needed */
8132 if (!islnm || add_6zero) {
8138 /* add fake 000000] if needed */
8151 } /* non-POSIX translation */
8153 } /* End of relative/absolute path handling */
8155 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8162 if (dir_start != 0) {
8164 /* First characters in a directory are handled special */
8165 while ((*unixptr == '/') ||
8166 ((*unixptr == '.') &&
8167 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8168 (&unixptr[1]==unixend)))) {
8173 /* Skip redundant / in specification */
8174 while ((*unixptr == '/') && (dir_start != 0)) {
8177 if (unixptr == lastslash)
8180 if (unixptr == lastslash)
8183 /* Skip redundant ./ characters */
8184 while ((*unixptr == '.') &&
8185 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8188 if (unixptr == lastslash)
8190 if (*unixptr == '/')
8193 if (unixptr == lastslash)
8196 /* Skip redundant ../ characters */
8197 while ((*unixptr == '.') && (unixptr[1] == '.') &&
8198 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8199 /* Set the backing up flag */
8205 unixptr++; /* first . */
8206 unixptr++; /* second . */
8207 if (unixptr == lastslash)
8209 if (*unixptr == '/') /* The slash */
8212 if (unixptr == lastslash)
8215 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8216 /* Not needed when VMS is pretending to be UNIX. */
8218 /* Is this loop stuck because of too many dots? */
8219 if (loop_flag == 0) {
8220 /* Exit the loop and pass the rest through */
8225 /* Are we done with directories yet? */
8226 if (unixptr >= lastslash) {
8228 /* Watch out for trailing dots */
8237 if (*unixptr == '/')
8241 /* Have we stopped backing up? */
8246 /* dir_start continues to be = 1 */
8248 if (*unixptr == '-') {
8250 *vmsptr++ = *unixptr++;
8254 /* Now are we done with directories yet? */
8255 if (unixptr >= lastslash) {
8257 /* Watch out for trailing dots */
8273 if (unixptr >= unixend)
8276 /* Normal characters - More EFS work probably needed */
8282 /* remove multiple / */
8283 while (unixptr[1] == '/') {
8286 if (unixptr == lastslash) {
8287 /* Watch out for trailing dots */
8299 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8300 /* Not needed when VMS is pretending to be UNIX. */
8304 if (unixptr != unixend)
8309 if ((unixptr < lastdot) || (unixptr < lastslash) ||
8310 (&unixptr[1] == unixend)) {
8316 /* trailing dot ==> '^..' on VMS */
8317 if (unixptr == unixend) {
8325 *vmsptr++ = *unixptr++;
8329 if (quoted && (&unixptr[1] == unixend)) {
8333 in_cnt = copy_expand_unix_filename_escape
8334 (vmsptr, unixptr, &out_cnt, utf8_fl);
8344 in_cnt = copy_expand_unix_filename_escape
8345 (vmsptr, unixptr, &out_cnt, utf8_fl);
8352 /* Make sure directory is closed */
8353 if (unixptr == lastslash) {
8355 vmsptr2 = vmsptr - 1;
8357 if (*vmsptr2 != ']') {
8360 /* directories do not end in a dot bracket */
8361 if (*vmsptr2 == '.') {
8365 if (*vmsptr2 != '^') {
8366 vmsptr--; /* back up over the dot */
8374 /* Add a trailing dot if a file with no extension */
8375 vmsptr2 = vmsptr - 1;
8377 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8378 (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8388 /* A convenience macro for copying dots in filenames and escaping
8389 * them when they haven't already been escaped, with guards to
8390 * avoid checking before the start of the buffer or advancing
8391 * beyond the end of it (allowing room for the NUL terminator).
8393 #define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
8394 if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8395 || ((vmsefsdot) == (vmsefsbuf))) \
8396 && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
8398 *((vmsefsdot)++) = '^'; \
8400 if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8401 *((vmsefsdot)++) = '.'; \
8404 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8406 int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag)
8412 unsigned long int infront = 0, hasdir = 1;
8415 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8416 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8418 if (vms_debug_fileify) {
8420 fprintf(stderr, "int_tovmsspec: path = NULL\n");
8422 fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8426 /* If we fail, we should be setting errno */
8428 set_vaxc_errno(SS$_BADPARAM);
8431 rslt_len = VMS_MAXRSS-1;
8433 /* '.' and '..' are "[]" and "[-]" for a quick check */
8434 if (path[0] == '.') {
8435 if (path[1] == '\0') {
8437 if (utf8_flag != NULL)
8442 if (path[1] == '.' && path[2] == '\0') {
8444 if (utf8_flag != NULL)
8451 /* Posix specifications are now a native VMS format */
8452 /*--------------------------------------------------*/
8453 #if __CRTL_VER >= 80200000
8454 if (decc_posix_compliant_pathnames) {
8455 if (strncmp(path,"\"^UP^",5) == 0) {
8456 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8462 /* This is really the only way to see if this is already in VMS format */
8463 sts = vms_split_path
8478 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8479 replacement, because the above parse just took care of most of
8480 what is needed to do vmspath when the specification is already
8483 And if it is not already, it is easier to do the conversion as
8484 part of this routine than to call this routine and then work on
8488 /* If VMS punctuation was found, it is already VMS format */
8489 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8490 if (utf8_flag != NULL)
8492 my_strlcpy(rslt, path, VMS_MAXRSS);
8493 if (vms_debug_fileify) {
8494 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8498 /* Now, what to do with trailing "." cases where there is no
8499 extension? If this is a UNIX specification, and EFS characters
8500 are enabled, then the trailing "." should be converted to a "^.".
8501 But if this was already a VMS specification, then it should be
8504 So in the case of ambiguity, leave the specification alone.
8508 /* If there is a possibility of UTF8, then if any UTF8 characters
8509 are present, then they must be converted to VTF-7
8511 if (utf8_flag != NULL)
8513 my_strlcpy(rslt, path, VMS_MAXRSS);
8514 if (vms_debug_fileify) {
8515 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8520 dirend = strrchr(path,'/');
8522 if (dirend == NULL) {
8523 /* If we get here with no Unix directory delimiters, then this is an
8524 * ambiguous file specification, such as a Unix glob specification, a
8525 * shell or make macro, or a filespec that would be valid except for
8526 * unescaped extended characters. The safest thing if it's a macro
8527 * is to pass it through as-is.
8529 if (strstr(path, "$(")) {
8530 my_strlcpy(rslt, path, VMS_MAXRSS);
8531 if (vms_debug_fileify) {
8532 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8538 else if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
8539 if (!*(dirend+2)) dirend +=2;
8540 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8541 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8546 lastdot = strrchr(cp2,'.');
8552 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8554 if (decc_disable_posix_root) {
8555 strcpy(rslt,"sys$disk:[000000]");
8558 strcpy(rslt,"sys$posix_root:[000000]");
8560 if (utf8_flag != NULL)
8562 if (vms_debug_fileify) {
8563 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8567 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8569 trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8570 if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8571 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8573 /* DECC special handling */
8575 if (strcmp(rslt,"bin") == 0) {
8576 strcpy(rslt,"sys$system");
8579 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8581 else if (strcmp(rslt,"tmp") == 0) {
8582 strcpy(rslt,"sys$scratch");
8585 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8587 else if (!decc_disable_posix_root) {
8588 strcpy(rslt, "sys$posix_root");
8592 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8593 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8595 else if (strcmp(rslt,"dev") == 0) {
8596 if (strncmp(cp2,"/null", 5) == 0) {
8597 if ((cp2[5] == 0) || (cp2[5] == '/')) {
8598 strcpy(rslt,"NLA0");
8602 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8608 trnend = islnm ? strlen(trndev) - 1 : 0;
8609 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8610 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8611 /* If the first element of the path is a logical name, determine
8612 * whether it has to be translated so we can add more directories. */
8613 if (!islnm || rooted) {
8616 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8620 if (cp2 != dirend) {
8621 my_strlcpy(rslt, trndev, VMS_MAXRSS);
8622 cp1 = rslt + trnend;
8629 if (decc_disable_posix_root) {
8635 PerlMem_free(trndev);
8640 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8641 cp2 += 2; /* skip over "./" - it's redundant */
8642 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8644 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8645 *(cp1++) = '-'; /* "../" --> "-" */
8648 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8649 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8650 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8651 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8654 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8655 /* Escape the extra dots in EFS file specifications */
8658 if (cp2 > dirend) cp2 = dirend;
8660 else *(cp1++) = '.';
8662 for (; cp2 < dirend; cp2++) {
8664 if (*(cp2-1) == '/') continue;
8665 if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
8668 else if (!infront && *cp2 == '.') {
8669 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8670 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
8671 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8672 if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
8673 else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
8678 if (cp2 == dirend) break;
8680 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8681 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8682 if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8683 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8685 *(cp1++) = '.'; /* Simulate trailing '/' */
8686 cp2 += 2; /* for loop will incr this to == dirend */
8688 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8691 if (decc_efs_charset == 0) {
8692 if (cp1 > rslt && *(cp1-1) == '^')
8693 cp1--; /* remove the escape, if any */
8694 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8697 VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8702 if (!infront && cp1 > rslt && *(cp1-1) == '-') *(cp1++) = '.';
8704 if (decc_efs_charset == 0) {
8705 if (cp1 > rslt && *(cp1-1) == '^')
8706 cp1--; /* remove the escape, if any */
8710 VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8715 cp2 += copy_expand_unix_filename_escape(cp1, cp2, &out_cnt, utf8_flag);
8716 cp2--; /* we're in a loop that will increment this */
8722 if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8723 if (hasdir) *(cp1++) = ']';
8724 if (*cp2 && *cp2 == '/') cp2++; /* check in case we ended with trailing '/' */
8731 if (decc_efs_charset == 0)
8737 if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
8743 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8744 decc_readdir_dropdotnotype) {
8745 VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8748 /* trailing dot ==> '^..' on VMS */
8755 *(cp1++) = *(cp2++);
8760 /* This could be a macro to be passed through */
8761 *(cp1++) = *(cp2++);
8763 const char * save_cp2;
8767 /* paranoid check */
8773 *(cp1++) = *(cp2++);
8774 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8775 *(cp1++) = *(cp2++);
8776 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8777 *(cp1++) = *(cp2++);
8780 *(cp1++) = *(cp2++);
8784 if (is_macro == 0) {
8785 /* Not really a macro - never mind */
8798 /* Don't escape again if following character is
8799 * already something we escape.
8801 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8802 *(cp1++) = *(cp2++);
8805 /* But otherwise fall through and escape it. */
8822 if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */
8824 *(cp1++) = *(cp2++);
8827 /* If it doesn't look like the beginning of a version number,
8828 * or we've been promised there are no version numbers, then
8831 if (decc_filename_unix_no_version) {
8835 size_t all_nums = strspn(cp2+1, "0123456789");
8836 if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0')
8839 *(cp1++) = *(cp2++);
8842 *(cp1++) = *(cp2++);
8845 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8849 /* Fix me for "^]", but that requires making sure that you do
8850 * not back up past the start of the filename
8852 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8857 if (utf8_flag != NULL)
8859 if (vms_debug_fileify) {
8860 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8864 } /* end of int_tovmsspec() */
8867 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8869 mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag)
8871 static char __tovmsspec_retbuf[VMS_MAXRSS];
8872 char * vmsspec, *ret_spec, *ret_buf;
8876 if (ret_buf == NULL) {
8878 Newx(vmsspec, VMS_MAXRSS, char);
8879 if (vmsspec == NULL)
8880 _ckvmssts(SS$_INSFMEM);
8883 ret_buf = __tovmsspec_retbuf;
8887 ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8889 if (ret_spec == NULL) {
8890 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8897 } /* end of mp_do_tovmsspec() */
8899 /* External entry points */
8901 Perl_tovmsspec(pTHX_ const char *path, char *buf)
8903 return do_tovmsspec(path, buf, 0, NULL);
8907 Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8909 return do_tovmsspec(path, buf, 1, NULL);
8913 Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8915 return do_tovmsspec(path, buf, 0, utf8_fl);
8919 Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8921 return do_tovmsspec(path, buf, 1, utf8_fl);
8924 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8925 /* Internal routine for use with out an explicit context present */
8927 int_tovmspath(const char *path, char *buf, int * utf8_fl)
8929 char * ret_spec, *pathified;
8934 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8935 if (pathified == NULL)
8936 _ckvmssts_noperl(SS$_INSFMEM);
8938 ret_spec = int_pathify_dirspec(path, pathified);
8940 if (ret_spec == NULL) {
8941 PerlMem_free(pathified);
8945 ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8947 PerlMem_free(pathified);
8952 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8954 mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
8956 static char __tovmspath_retbuf[VMS_MAXRSS];
8958 char *pathified, *vmsified, *cp;
8960 if (path == NULL) return NULL;
8961 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8962 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8963 if (int_pathify_dirspec(path, pathified) == NULL) {
8964 PerlMem_free(pathified);
8970 Newx(vmsified, VMS_MAXRSS, char);
8971 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8972 PerlMem_free(pathified);
8973 if (vmsified) Safefree(vmsified);
8976 PerlMem_free(pathified);
8981 vmslen = strlen(vmsified);
8982 Newx(cp,vmslen+1,char);
8983 memcpy(cp,vmsified,vmslen);
8989 my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8991 return __tovmspath_retbuf;
8994 } /* end of do_tovmspath() */
8996 /* External entry points */
8998 Perl_tovmspath(pTHX_ const char *path, char *buf)
9000 return do_tovmspath(path, buf, 0, NULL);
9004 Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9006 return do_tovmspath(path, buf, 1, NULL);
9010 Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9012 return do_tovmspath(path, buf, 0, utf8_fl);
9016 Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9018 return do_tovmspath(path, buf, 1, utf8_fl);
9022 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9024 mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
9026 static char __tounixpath_retbuf[VMS_MAXRSS];
9028 char *pathified, *unixified, *cp;
9030 if (path == NULL) return NULL;
9031 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
9032 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9033 if (int_pathify_dirspec(path, pathified) == NULL) {
9034 PerlMem_free(pathified);
9040 Newx(unixified, VMS_MAXRSS, char);
9042 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9043 PerlMem_free(pathified);
9044 if (unixified) Safefree(unixified);
9047 PerlMem_free(pathified);
9052 unixlen = strlen(unixified);
9053 Newx(cp,unixlen+1,char);
9054 memcpy(cp,unixified,unixlen);
9056 Safefree(unixified);
9060 my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
9061 Safefree(unixified);
9062 return __tounixpath_retbuf;
9065 } /* end of do_tounixpath() */
9067 /* External entry points */
9069 Perl_tounixpath(pTHX_ const char *path, char *buf)
9071 return do_tounixpath(path, buf, 0, NULL);
9075 Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9077 return do_tounixpath(path, buf, 1, NULL);
9081 Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9083 return do_tounixpath(path, buf, 0, utf8_fl);
9087 Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9089 return do_tounixpath(path, buf, 1, utf8_fl);
9093 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
9095 *****************************************************************************
9097 * Copyright (C) 1989-1994, 2007 by *
9098 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
9100 * Permission is hereby granted for the reproduction of this software *
9101 * on condition that this copyright notice is included in source *
9102 * distributions of the software. The code may be modified and *
9103 * distributed under the same terms as Perl itself. *
9105 * 27-Aug-1994 Modified for inclusion in perl5 *
9106 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
9107 *****************************************************************************
9111 * getredirection() is intended to aid in porting C programs
9112 * to VMS (Vax-11 C). The native VMS environment does not support
9113 * '>' and '<' I/O redirection, or command line wild card expansion,
9114 * or a command line pipe mechanism using the '|' AND background
9115 * command execution '&'. All of these capabilities are provided to any
9116 * C program which calls this procedure as the first thing in the
9118 * The piping mechanism will probably work with almost any 'filter' type
9119 * of program. With suitable modification, it may useful for other
9120 * portability problems as well.
9122 * Author: Mark Pizzolato (mark AT infocomm DOT com)
9126 struct list_item *next;
9130 static void add_item(struct list_item **head,
9131 struct list_item **tail,
9135 static void mp_expand_wild_cards(pTHX_ char *item,
9136 struct list_item **head,
9137 struct list_item **tail,
9140 static int background_process(pTHX_ int argc, char **argv);
9142 static void pipe_and_fork(pTHX_ char **cmargv);
9144 /*{{{ void getredirection(int *ac, char ***av)*/
9146 mp_getredirection(pTHX_ int *ac, char ***av)
9148 * Process vms redirection arg's. Exit if any error is seen.
9149 * If getredirection() processes an argument, it is erased
9150 * from the vector. getredirection() returns a new argc and argv value.
9151 * In the event that a background command is requested (by a trailing "&"),
9152 * this routine creates a background subprocess, and simply exits the program.
9154 * Warning: do not try to simplify the code for vms. The code
9155 * presupposes that getredirection() is called before any data is
9156 * read from stdin or written to stdout.
9158 * Normal usage is as follows:
9164 * getredirection(&argc, &argv);
9168 int argc = *ac; /* Argument Count */
9169 char **argv = *av; /* Argument Vector */
9170 char *ap; /* Argument pointer */
9171 int j; /* argv[] index */
9172 int item_count = 0; /* Count of Items in List */
9173 struct list_item *list_head = 0; /* First Item in List */
9174 struct list_item *list_tail; /* Last Item in List */
9175 char *in = NULL; /* Input File Name */
9176 char *out = NULL; /* Output File Name */
9177 char *outmode = "w"; /* Mode to Open Output File */
9178 char *err = NULL; /* Error File Name */
9179 char *errmode = "w"; /* Mode to Open Error File */
9180 int cmargc = 0; /* Piped Command Arg Count */
9181 char **cmargv = NULL;/* Piped Command Arg Vector */
9184 * First handle the case where the last thing on the line ends with
9185 * a '&'. This indicates the desire for the command to be run in a
9186 * subprocess, so we satisfy that desire.
9189 if (0 == strcmp("&", ap))
9190 exit(background_process(aTHX_ --argc, argv));
9191 if (*ap && '&' == ap[strlen(ap)-1])
9193 ap[strlen(ap)-1] = '\0';
9194 exit(background_process(aTHX_ argc, argv));
9197 * Now we handle the general redirection cases that involve '>', '>>',
9198 * '<', and pipes '|'.
9200 for (j = 0; j < argc; ++j)
9202 if (0 == strcmp("<", argv[j]))
9206 fprintf(stderr,"No input file after < on command line");
9207 exit(LIB$_WRONUMARG);
9212 if ('<' == *(ap = argv[j]))
9217 if (0 == strcmp(">", ap))
9221 fprintf(stderr,"No output file after > on command line");
9222 exit(LIB$_WRONUMARG);
9241 fprintf(stderr,"No output file after > or >> on command line");
9242 exit(LIB$_WRONUMARG);
9246 if (('2' == *ap) && ('>' == ap[1]))
9263 fprintf(stderr,"No output file after 2> or 2>> on command line");
9264 exit(LIB$_WRONUMARG);
9268 if (0 == strcmp("|", argv[j]))
9272 fprintf(stderr,"No command into which to pipe on command line");
9273 exit(LIB$_WRONUMARG);
9275 cmargc = argc-(j+1);
9276 cmargv = &argv[j+1];
9280 if ('|' == *(ap = argv[j]))
9288 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9291 * Allocate and fill in the new argument vector, Some Unix's terminate
9292 * the list with an extra null pointer.
9294 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9295 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9297 for (j = 0; j < item_count; ++j, list_head = list_head->next)
9298 argv[j] = list_head->value;
9304 fprintf(stderr,"'|' and '>' may not both be specified on command line");
9305 exit(LIB$_INVARGORD);
9307 pipe_and_fork(aTHX_ cmargv);
9310 /* Check for input from a pipe (mailbox) */
9312 if (in == NULL && 1 == isapipe(0))
9314 char mbxname[L_tmpnam];
9316 long int dvi_item = DVI$_DEVBUFSIZ;
9317 $DESCRIPTOR(mbxnam, "");
9318 $DESCRIPTOR(mbxdevnam, "");
9320 /* Input from a pipe, reopen it in binary mode to disable */
9321 /* carriage control processing. */
9323 fgetname(stdin, mbxname, 1);
9324 mbxnam.dsc$a_pointer = mbxname;
9325 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9326 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9327 mbxdevnam.dsc$a_pointer = mbxname;
9328 mbxdevnam.dsc$w_length = sizeof(mbxname);
9329 dvi_item = DVI$_DEVNAM;
9330 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9331 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9334 freopen(mbxname, "rb", stdin);
9337 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9341 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9343 fprintf(stderr,"Can't open input file %s as stdin",in);
9346 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9348 fprintf(stderr,"Can't open output file %s as stdout",out);
9351 if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
9354 if (strcmp(err,"&1") == 0) {
9355 dup2(fileno(stdout), fileno(stderr));
9356 vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
9359 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9361 fprintf(stderr,"Can't open error file %s as stderr",err);
9365 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9369 vmssetuserlnm("SYS$ERROR", err);
9372 #ifdef ARGPROC_DEBUG
9373 PerlIO_printf(Perl_debug_log, "Arglist:\n");
9374 for (j = 0; j < *ac; ++j)
9375 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9377 /* Clear errors we may have hit expanding wildcards, so they don't
9378 show up in Perl's $! later */
9379 set_errno(0); set_vaxc_errno(1);
9380 } /* end of getredirection() */
9384 add_item(struct list_item **head, struct list_item **tail, char *value, int *count)
9388 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9389 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9393 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9394 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9395 *tail = (*tail)->next;
9397 (*tail)->value = value;
9402 mp_expand_wild_cards(pTHX_ char *item, struct list_item **head,
9403 struct list_item **tail, int *count)
9406 unsigned long int context = 0;
9414 $DESCRIPTOR(filespec, "");
9415 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9416 $DESCRIPTOR(resultspec, "");
9417 unsigned long int lff_flags = 0;
9421 #ifdef VMS_LONGNAME_SUPPORT
9422 lff_flags = LIB$M_FIL_LONG_NAMES;
9425 for (cp = item; *cp; cp++) {
9426 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9427 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9429 if (!*cp || isspace(*cp))
9431 add_item(head, tail, item, count);
9436 /* "double quoted" wild card expressions pass as is */
9437 /* From DCL that means using e.g.: */
9438 /* perl program """perl.*""" */
9439 item_len = strlen(item);
9440 if ( '"' == *item && '"' == item[item_len-1] )
9443 item[item_len-2] = '\0';
9444 add_item(head, tail, item, count);
9448 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9449 resultspec.dsc$b_class = DSC$K_CLASS_D;
9450 resultspec.dsc$a_pointer = NULL;
9451 vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9452 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9453 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9454 filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9455 if (!isunix || !filespec.dsc$a_pointer)
9456 filespec.dsc$a_pointer = item;
9457 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9459 * Only return version specs, if the caller specified a version
9461 had_version = strchr(item, ';');
9463 * Only return device and directory specs, if the caller specified either.
9465 had_device = strchr(item, ':');
9466 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9468 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9469 (&filespec, &resultspec, &context,
9470 &defaultspec, 0, &rms_sts, &lff_flags)))
9475 string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9476 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9477 my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9478 if (NULL == had_version)
9479 *(strrchr(string, ';')) = '\0';
9480 if ((!had_directory) && (had_device == NULL))
9482 if (NULL == (devdir = strrchr(string, ']')))
9483 devdir = strrchr(string, '>');
9484 my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9487 * Be consistent with what the C RTL has already done to the rest of
9488 * the argv items and lowercase all of these names.
9490 if (!decc_efs_case_preserve) {
9491 for (c = string; *c; ++c)
9495 if (isunix) trim_unixpath(string,item,1);
9496 add_item(head, tail, string, count);
9499 PerlMem_free(vmsspec);
9500 if (sts != RMS$_NMF)
9502 set_vaxc_errno(sts);
9505 case RMS$_FNF: case RMS$_DNF:
9506 set_errno(ENOENT); break;
9508 set_errno(ENOTDIR); break;
9510 set_errno(ENODEV); break;
9511 case RMS$_FNM: case RMS$_SYN:
9512 set_errno(EINVAL); break;
9514 set_errno(EACCES); break;
9516 _ckvmssts_noperl(sts);
9520 add_item(head, tail, item, count);
9521 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9522 _ckvmssts_noperl(lib$find_file_end(&context));
9527 pipe_and_fork(pTHX_ char **cmargv)
9530 struct dsc$descriptor_s *vmscmd;
9531 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9532 int sts, j, l, ismcr, quote, tquote = 0;
9534 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
9535 vms_execfree(vmscmd);
9540 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
9541 && toupper(*(q+2)) == 'R' && !*(q+3);
9543 while (q && l < MAX_DCL_LINE_LENGTH) {
9545 if (j > 0 && quote) {
9551 if (ismcr && j > 1) quote = 1;
9552 tquote = (strchr(q,' ')) != NULL || *q == '\0';
9555 if (quote || tquote) {
9561 if ((quote||tquote) && *q == '"') {
9571 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9573 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9578 background_process(pTHX_ int argc, char **argv)
9580 char command[MAX_DCL_SYMBOL + 1] = "$";
9581 $DESCRIPTOR(value, "");
9582 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9583 static $DESCRIPTOR(null, "NLA0:");
9584 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9586 $DESCRIPTOR(pidstr, "");
9588 unsigned long int flags = 17, one = 1, retsts;
9591 len = my_strlcat(command, argv[0], sizeof(command));
9592 while (--argc && (len < MAX_DCL_SYMBOL))
9594 my_strlcat(command, " \"", sizeof(command));
9595 my_strlcat(command, *(++argv), sizeof(command));
9596 len = my_strlcat(command, "\"", sizeof(command));
9598 value.dsc$a_pointer = command;
9599 value.dsc$w_length = strlen(value.dsc$a_pointer);
9600 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9601 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9602 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9603 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9606 _ckvmssts_noperl(retsts);
9608 #ifdef ARGPROC_DEBUG
9609 PerlIO_printf(Perl_debug_log, "%s\n", command);
9611 sprintf(pidstring, "%08X", pid);
9612 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9613 pidstr.dsc$a_pointer = pidstring;
9614 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9615 lib$set_symbol(&pidsymbol, &pidstr);
9619 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9622 /* OS-specific initialization at image activation (not thread startup) */
9623 /* Older VAXC header files lack these constants */
9624 #ifndef JPI$_RIGHTS_SIZE
9625 # define JPI$_RIGHTS_SIZE 817
9627 #ifndef KGB$M_SUBSYSTEM
9628 # define KGB$M_SUBSYSTEM 0x8
9631 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9633 /*{{{void vms_image_init(int *, char ***)*/
9635 vms_image_init(int *argcp, char ***argvp)
9638 char eqv[LNM$C_NAMLENGTH+1] = "";
9639 unsigned int len, tabct = 8, tabidx = 0;
9640 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9641 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9642 unsigned short int dummy, rlen;
9643 struct dsc$descriptor_s **tabvec;
9644 #if defined(PERL_IMPLICIT_CONTEXT)
9647 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
9648 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
9649 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9652 #ifdef KILL_BY_SIGPRC
9653 Perl_csighandler_init();
9656 /* This was moved from the pre-image init handler because on threaded */
9657 /* Perl it was always returning 0 for the default value. */
9658 status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9661 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9664 initial = decc$feature_get_value(s, 4);
9666 /* initial is: 0 if nothing has set the feature */
9667 /* -1 if initialized to default */
9668 /* 1 if set by logical name */
9669 /* 2 if set by decc$feature_set_value */
9670 decc_disable_posix_root = decc$feature_get_value(s, 1);
9672 /* If the value is not valid, force the feature off */
9673 if (decc_disable_posix_root < 0) {
9674 decc$feature_set_value(s, 1, 1);
9675 decc_disable_posix_root = 1;
9679 /* Nothing has asked for it explicitly, so use our own default. */
9680 decc_disable_posix_root = 1;
9681 decc$feature_set_value(s, 1, 1);
9686 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9687 _ckvmssts_noperl(iosb[0]);
9688 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9689 if (iprv[i]) { /* Running image installed with privs? */
9690 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
9695 /* Rights identifiers might trigger tainting as well. */
9696 if (!will_taint && (rlen || rsz)) {
9697 while (rlen < rsz) {
9698 /* We didn't get all the identifiers on the first pass. Allocate a
9699 * buffer much larger than $GETJPI wants (rsz is size in bytes that
9700 * were needed to hold all identifiers at time of last call; we'll
9701 * allocate that many unsigned long ints), and go back and get 'em.
9702 * If it gave us less than it wanted to despite ample buffer space,
9703 * something's broken. Is your system missing a system identifier?
9705 if (rsz <= jpilist[1].buflen) {
9706 /* Perl_croak accvios when used this early in startup. */
9707 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9708 rsz, (unsigned long) jpilist[1].buflen,
9709 "Check your rights database for corruption.\n");
9712 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9713 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9714 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9715 jpilist[1].buflen = rsz * sizeof(unsigned long int);
9716 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9717 _ckvmssts_noperl(iosb[0]);
9719 mask = (unsigned long int *)jpilist[1].bufadr;
9720 /* Check attribute flags for each identifier (2nd longword); protected
9721 * subsystem identifiers trigger tainting.
9723 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9724 if (mask[i] & KGB$M_SUBSYSTEM) {
9729 if (mask != rlst) PerlMem_free(mask);
9732 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9733 * logical, some versions of the CRTL will add a phanthom /000000/
9734 * directory. This needs to be removed.
9736 if (decc_filename_unix_report) {
9739 ulen = strlen(argvp[0][0]);
9741 zeros = strstr(argvp[0][0], "/000000/");
9742 if (zeros != NULL) {
9744 mlen = ulen - (zeros - argvp[0][0]) - 7;
9745 memmove(zeros, &zeros[7], mlen);
9747 argvp[0][0][ulen] = '\0';
9750 /* It also may have a trailing dot that needs to be removed otherwise
9751 * it will be converted to VMS mode incorrectly.
9754 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9755 argvp[0][0][ulen] = '\0';
9758 /* We need to use this hack to tell Perl it should run with tainting,
9759 * since its tainting flag may be part of the PL_curinterp struct, which
9760 * hasn't been allocated when vms_image_init() is called.
9763 char **newargv, **oldargv;
9765 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9766 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9767 newargv[0] = oldargv[0];
9768 newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9769 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9770 strcpy(newargv[1], "-T");
9771 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9773 newargv[*argcp] = NULL;
9774 /* We orphan the old argv, since we don't know where it's come from,
9775 * so we don't know how to free it.
9779 else { /* Did user explicitly request tainting? */
9781 char *cp, **av = *argvp;
9782 for (i = 1; i < *argcp; i++) {
9783 if (*av[i] != '-') break;
9784 for (cp = av[i]+1; *cp; cp++) {
9785 if (*cp == 'T') { will_taint = 1; break; }
9786 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9787 strchr("DFIiMmx",*cp)) break;
9789 if (will_taint) break;
9794 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9797 tabvec = (struct dsc$descriptor_s **)
9798 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9799 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9801 else if (tabidx >= tabct) {
9803 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9804 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9806 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9807 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9808 tabvec[tabidx]->dsc$w_length = len;
9809 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9810 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_S;
9811 tabvec[tabidx]->dsc$a_pointer = (char *)PerlMem_malloc(len + 1);
9812 if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9813 my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
9815 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9817 getredirection(argcp,argvp);
9818 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9820 # include <reentrancy.h>
9821 decc$set_reentrancy(C$C_MULTITHREAD);
9830 * Trim Unix-style prefix off filespec, so it looks like what a shell
9831 * glob expansion would return (i.e. from specified prefix on, not
9832 * full path). Note that returned filespec is Unix-style, regardless
9833 * of whether input filespec was VMS-style or Unix-style.
9835 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9836 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9837 * vector of options; at present, only bit 0 is used, and if set tells
9838 * trim unixpath to try the current default directory as a prefix when
9839 * presented with a possibly ambiguous ... wildcard.
9841 * Returns !=0 on success, with trimmed filespec replacing contents of
9842 * fspec, and 0 on failure, with contents of fpsec unchanged.
9844 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9846 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9848 char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9849 int tmplen, reslen = 0, dirs = 0;
9851 if (!wildspec || !fspec) return 0;
9853 unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9854 if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9856 if (strpbrk(wildspec,"]>:") != NULL) {
9857 if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9858 PerlMem_free(unixwild);
9863 my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9865 unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9866 if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9867 if (strpbrk(fspec,"]>:") != NULL) {
9868 if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9869 PerlMem_free(unixwild);
9870 PerlMem_free(unixified);
9873 else base = unixified;
9874 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9875 * check to see that final result fits into (isn't longer than) fspec */
9876 reslen = strlen(fspec);
9880 /* No prefix or absolute path on wildcard, so nothing to remove */
9881 if (!*tplate || *tplate == '/') {
9882 PerlMem_free(unixwild);
9883 if (base == fspec) {
9884 PerlMem_free(unixified);
9887 tmplen = strlen(unixified);
9888 if (tmplen > reslen) {
9889 PerlMem_free(unixified);
9890 return 0; /* not enough space */
9892 /* Copy unixified resultant, including trailing NUL */
9893 memmove(fspec,unixified,tmplen+1);
9894 PerlMem_free(unixified);
9898 for (end = base; *end; end++) ; /* Find end of resultant filespec */
9899 if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9900 for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9901 for (cp1 = end ;cp1 >= base; cp1--)
9902 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9904 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9905 PerlMem_free(unixified);
9906 PerlMem_free(unixwild);
9911 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9912 int ells = 1, totells, segdirs, match;
9913 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9914 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9916 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9918 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9919 tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9920 if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9921 if (ellipsis == tplate && opts & 1) {
9922 /* Template begins with an ellipsis. Since we can't tell how many
9923 * directory names at the front of the resultant to keep for an
9924 * arbitrary starting point, we arbitrarily choose the current
9925 * default directory as a starting point. If it's there as a prefix,
9926 * clip it off. If not, fall through and act as if the leading
9927 * ellipsis weren't there (i.e. return shortest possible path that
9928 * could match template).
9930 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9932 PerlMem_free(unixified);
9933 PerlMem_free(unixwild);
9936 if (!decc_efs_case_preserve) {
9937 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9938 if (_tolower(*cp1) != _tolower(*cp2)) break;
9940 segdirs = dirs - totells; /* Min # of dirs we must have left */
9941 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9942 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9943 memmove(fspec,cp2+1,end - cp2);
9945 PerlMem_free(unixified);
9946 PerlMem_free(unixwild);
9950 /* First off, back up over constant elements at end of path */
9952 for (front = end ; front >= base; front--)
9953 if (*front == '/' && !dirs--) { front++; break; }
9955 lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9956 if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9957 for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9959 if (!decc_efs_case_preserve) {
9960 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9968 PerlMem_free(unixified);
9969 PerlMem_free(unixwild);
9970 PerlMem_free(lcres);
9971 return 0; /* Path too long. */
9974 *cp2 = '\0'; /* Pick up with memcpy later */
9975 lcfront = lcres + (front - base);
9976 /* Now skip over each ellipsis and try to match the path in front of it. */
9978 for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9979 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9980 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
9981 if (cp1 < tplate) break; /* template started with an ellipsis */
9982 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9983 ellipsis = cp1; continue;
9985 wilddsc.dsc$a_pointer = tpl;
9986 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9988 for (segdirs = 0, cp2 = tpl;
9989 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9991 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9993 if (!decc_efs_case_preserve) {
9994 *cp2 = _tolower(*cp1); /* else lowercase for match */
9997 *cp2 = *cp1; /* else preserve case for match */
10000 if (*cp2 == '/') segdirs++;
10002 if (cp1 != ellipsis - 1) {
10004 PerlMem_free(unixified);
10005 PerlMem_free(unixwild);
10006 PerlMem_free(lcres);
10007 return 0; /* Path too long */
10009 /* Back up at least as many dirs as in template before matching */
10010 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10011 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10012 for (match = 0; cp1 > lcres;) {
10013 resdsc.dsc$a_pointer = cp1;
10014 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10016 if (match == 1) lcfront = cp1;
10018 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10022 PerlMem_free(unixified);
10023 PerlMem_free(unixwild);
10024 PerlMem_free(lcres);
10025 return 0; /* Can't find prefix ??? */
10027 if (match > 1 && opts & 1) {
10028 /* This ... wildcard could cover more than one set of dirs (i.e.
10029 * a set of similar dir names is repeated). If the template
10030 * contains more than 1 ..., upstream elements could resolve the
10031 * ambiguity, but it's not worth a full backtracking setup here.
10032 * As a quick heuristic, clip off the current default directory
10033 * if it's present to find the trimmed spec, else use the
10034 * shortest string that this ... could cover.
10036 char def[NAM$C_MAXRSS+1], *st;
10038 if (getcwd(def, sizeof def,0) == NULL) {
10039 PerlMem_free(unixified);
10040 PerlMem_free(unixwild);
10041 PerlMem_free(lcres);
10045 if (!decc_efs_case_preserve) {
10046 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10047 if (_tolower(*cp1) != _tolower(*cp2)) break;
10049 segdirs = dirs - totells; /* Min # of dirs we must have left */
10050 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10051 if (*cp1 == '\0' && *cp2 == '/') {
10052 memmove(fspec,cp2+1,end - cp2);
10054 PerlMem_free(unixified);
10055 PerlMem_free(unixwild);
10056 PerlMem_free(lcres);
10059 /* Nope -- stick with lcfront from above and keep going. */
10062 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10064 PerlMem_free(unixified);
10065 PerlMem_free(unixwild);
10066 PerlMem_free(lcres);
10070 } /* end of trim_unixpath() */
10075 * VMS readdir() routines.
10076 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10078 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
10079 * Minor modifications to original routines.
10082 /* readdir may have been redefined by reentr.h, so make sure we get
10083 * the local version for what we do here.
10088 #if !defined(PERL_IMPLICIT_CONTEXT)
10089 # define readdir Perl_readdir
10091 # define readdir(a) Perl_readdir(aTHX_ a)
10094 /* Number of elements in vms_versions array */
10095 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
10098 * Open a directory, return a handle for later use.
10100 /*{{{ DIR *opendir(char*name) */
10102 Perl_opendir(pTHX_ const char *name)
10108 Newx(dir, VMS_MAXRSS, char);
10109 if (int_tovmspath(name, dir, NULL) == NULL) {
10113 /* Check access before stat; otherwise stat does not
10114 * accurately report whether it's a directory.
10116 if (!strstr(dir, "::") /* sys$check_access doesn't do remotes */
10117 && !cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10118 /* cando_by_name has already set errno */
10122 if (flex_stat(dir,&sb) == -1) return NULL;
10123 if (!S_ISDIR(sb.st_mode)) {
10125 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
10128 /* Get memory for the handle, and the pattern. */
10130 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10132 /* Fill in the fields; mainly playing with the descriptor. */
10133 sprintf(dd->pattern, "%s*.*",dir);
10138 /* By saying we want the result of readdir() in unix format, we are really
10139 * saying we want all the escapes removed, translating characters that
10140 * must be escaped in a VMS-format name to their unescaped form, which is
10141 * presumably allowed in a Unix-format name.
10143 dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
10144 dd->pat.dsc$a_pointer = dd->pattern;
10145 dd->pat.dsc$w_length = strlen(dd->pattern);
10146 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10147 dd->pat.dsc$b_class = DSC$K_CLASS_S;
10148 #if defined(USE_ITHREADS)
10149 Newx(dd->mutex,1,perl_mutex);
10150 MUTEX_INIT( (perl_mutex *) dd->mutex );
10156 } /* end of opendir() */
10160 * Set the flag to indicate we want versions or not.
10162 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10164 vmsreaddirversions(DIR *dd, int flag)
10167 dd->flags |= PERL_VMSDIR_M_VERSIONS;
10169 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10174 * Free up an opened directory.
10176 /*{{{ void closedir(DIR *dd)*/
10178 Perl_closedir(DIR *dd)
10182 sts = lib$find_file_end(&dd->context);
10183 Safefree(dd->pattern);
10184 #if defined(USE_ITHREADS)
10185 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10186 Safefree(dd->mutex);
10193 * Collect all the version numbers for the current file.
10196 collectversions(pTHX_ DIR *dd)
10198 struct dsc$descriptor_s pat;
10199 struct dsc$descriptor_s res;
10201 char *p, *text, *buff;
10203 unsigned long context, tmpsts;
10205 /* Convenient shorthand. */
10208 /* Add the version wildcard, ignoring the "*.*" put on before */
10209 i = strlen(dd->pattern);
10210 Newx(text,i + e->d_namlen + 3,char);
10211 my_strlcpy(text, dd->pattern, i + 1);
10212 sprintf(&text[i - 3], "%s;*", e->d_name);
10214 /* Set up the pattern descriptor. */
10215 pat.dsc$a_pointer = text;
10216 pat.dsc$w_length = i + e->d_namlen - 1;
10217 pat.dsc$b_dtype = DSC$K_DTYPE_T;
10218 pat.dsc$b_class = DSC$K_CLASS_S;
10220 /* Set up result descriptor. */
10221 Newx(buff, VMS_MAXRSS, char);
10222 res.dsc$a_pointer = buff;
10223 res.dsc$w_length = VMS_MAXRSS - 1;
10224 res.dsc$b_dtype = DSC$K_DTYPE_T;
10225 res.dsc$b_class = DSC$K_CLASS_S;
10227 /* Read files, collecting versions. */
10228 for (context = 0, e->vms_verscount = 0;
10229 e->vms_verscount < VERSIZE(e);
10230 e->vms_verscount++) {
10231 unsigned long rsts;
10232 unsigned long flags = 0;
10234 #ifdef VMS_LONGNAME_SUPPORT
10235 flags = LIB$M_FIL_LONG_NAMES;
10237 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10238 if (tmpsts == RMS$_NMF || context == 0) break;
10240 buff[VMS_MAXRSS - 1] = '\0';
10241 if ((p = strchr(buff, ';')))
10242 e->vms_versions[e->vms_verscount] = atoi(p + 1);
10244 e->vms_versions[e->vms_verscount] = -1;
10247 _ckvmssts(lib$find_file_end(&context));
10251 } /* end of collectversions() */
10254 * Read the next entry from the directory.
10256 /*{{{ struct dirent *readdir(DIR *dd)*/
10258 Perl_readdir(pTHX_ DIR *dd)
10260 struct dsc$descriptor_s res;
10262 unsigned long int tmpsts;
10263 unsigned long rsts;
10264 unsigned long flags = 0;
10265 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10266 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10268 /* Set up result descriptor, and get next file. */
10269 Newx(buff, VMS_MAXRSS, char);
10270 res.dsc$a_pointer = buff;
10271 res.dsc$w_length = VMS_MAXRSS - 1;
10272 res.dsc$b_dtype = DSC$K_DTYPE_T;
10273 res.dsc$b_class = DSC$K_CLASS_S;
10275 #ifdef VMS_LONGNAME_SUPPORT
10276 flags = LIB$M_FIL_LONG_NAMES;
10279 tmpsts = lib$find_file
10280 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10281 if (dd->context == 0)
10282 tmpsts = RMS$_NMF; /* None left. (should be set, but make sure) */
10284 if (!(tmpsts & 1)) {
10287 break; /* no more files considered success */
10289 SETERRNO(EACCES, tmpsts); break;
10291 SETERRNO(ENODEV, tmpsts); break;
10293 SETERRNO(ENOTDIR, tmpsts); break;
10294 case RMS$_FNF: case RMS$_DNF:
10295 SETERRNO(ENOENT, tmpsts); break;
10297 SETERRNO(EVMSERR, tmpsts);
10303 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10304 buff[res.dsc$w_length] = '\0';
10305 p = buff + res.dsc$w_length;
10306 while (--p >= buff) if (!isspace(*p)) break;
10308 if (!decc_efs_case_preserve) {
10309 for (p = buff; *p; p++) *p = _tolower(*p);
10312 /* Skip any directory component and just copy the name. */
10313 sts = vms_split_path
10328 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10330 /* In Unix report mode, remove the ".dir;1" from the name */
10331 /* if it is a real directory. */
10332 if (decc_filename_unix_report && decc_efs_charset) {
10333 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10337 ret_sts = flex_lstat(buff, &statbuf);
10338 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10345 /* Drop NULL extensions on UNIX file specification */
10346 if ((e_len == 1) && decc_readdir_dropdotnotype) {
10352 memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10353 dd->entry.d_name[n_len + e_len] = '\0';
10354 dd->entry.d_namlen = n_len + e_len;
10356 /* Convert the filename to UNIX format if needed */
10357 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10359 /* Translate the encoded characters. */
10360 /* Fixme: Unicode handling could result in embedded 0 characters */
10361 if (strchr(dd->entry.d_name, '^') != NULL) {
10362 char new_name[256];
10364 p = dd->entry.d_name;
10367 int inchars_read, outchars_added;
10368 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10370 q += outchars_added;
10372 /* if outchars_added > 1, then this is a wide file specification */
10373 /* Wide file specifications need to be passed in Perl */
10374 /* counted strings apparently with a Unicode flag */
10377 dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10381 dd->entry.vms_verscount = 0;
10382 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10386 } /* end of readdir() */
10390 * Read the next entry from the directory -- thread-safe version.
10392 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10394 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10398 MUTEX_LOCK( (perl_mutex *) dd->mutex );
10400 entry = readdir(dd);
10402 retval = ( *result == NULL ? errno : 0 );
10404 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10408 } /* end of readdir_r() */
10412 * Return something that can be used in a seekdir later.
10414 /*{{{ long telldir(DIR *dd)*/
10416 Perl_telldir(DIR *dd)
10423 * Return to a spot where we used to be. Brute force.
10425 /*{{{ void seekdir(DIR *dd,long count)*/
10427 Perl_seekdir(pTHX_ DIR *dd, long count)
10431 /* If we haven't done anything yet... */
10432 if (dd->count == 0)
10435 /* Remember some state, and clear it. */
10436 old_flags = dd->flags;
10437 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10438 _ckvmssts(lib$find_file_end(&dd->context));
10441 /* The increment is in readdir(). */
10442 for (dd->count = 0; dd->count < count; )
10445 dd->flags = old_flags;
10447 } /* end of seekdir() */
10450 /* VMS subprocess management
10452 * my_vfork() - just a vfork(), after setting a flag to record that
10453 * the current script is trying a Unix-style fork/exec.
10455 * vms_do_aexec() and vms_do_exec() are called in response to the
10456 * perl 'exec' function. If this follows a vfork call, then they
10457 * call out the regular perl routines in doio.c which do an
10458 * execvp (for those who really want to try this under VMS).
10459 * Otherwise, they do exactly what the perl docs say exec should
10460 * do - terminate the current script and invoke a new command
10461 * (See below for notes on command syntax.)
10463 * do_aspawn() and do_spawn() implement the VMS side of the perl
10464 * 'system' function.
10466 * Note on command arguments to perl 'exec' and 'system': When handled
10467 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10468 * are concatenated to form a DCL command string. If the first non-numeric
10469 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10470 * the command string is handed off to DCL directly. Otherwise,
10471 * the first token of the command is taken as the filespec of an image
10472 * to run. The filespec is expanded using a default type of '.EXE' and
10473 * the process defaults for device, directory, etc., and if found, the resultant
10474 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10475 * the command string as parameters. This is perhaps a bit complicated,
10476 * but I hope it will form a happy medium between what VMS folks expect
10477 * from lib$spawn and what Unix folks expect from exec.
10480 static int vfork_called;
10482 /*{{{int my_vfork(void)*/
10493 vms_execfree(struct dsc$descriptor_s *vmscmd)
10496 if (vmscmd->dsc$a_pointer) {
10497 PerlMem_free(vmscmd->dsc$a_pointer);
10499 PerlMem_free(vmscmd);
10504 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10506 char *junk, *tmps = NULL;
10514 tmps = SvPV(really,rlen);
10516 cmdlen += rlen + 1;
10521 for (idx++; idx <= sp; idx++) {
10523 junk = SvPVx(*idx,rlen);
10524 cmdlen += rlen ? rlen + 1 : 0;
10527 Newx(PL_Cmd, cmdlen+1, char);
10529 if (tmps && *tmps) {
10530 my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10533 else *PL_Cmd = '\0';
10534 while (++mark <= sp) {
10536 char *s = SvPVx(*mark,n_a);
10538 if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10539 my_strlcat(PL_Cmd, s, cmdlen+1);
10544 } /* end of setup_argstr() */
10547 static unsigned long int
10548 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10549 struct dsc$descriptor_s **pvmscmd)
10553 char image_name[NAM$C_MAXRSS+1];
10554 char image_argv[NAM$C_MAXRSS+1];
10555 $DESCRIPTOR(defdsc,".EXE");
10556 $DESCRIPTOR(defdsc2,".");
10557 struct dsc$descriptor_s resdsc;
10558 struct dsc$descriptor_s *vmscmd;
10559 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10560 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10561 char *s, *rest, *cp, *wordbreak;
10566 vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10567 if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10569 /* vmsspec is a DCL command buffer, not just a filename */
10570 vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10571 if (vmsspec == NULL)
10572 _ckvmssts_noperl(SS$_INSFMEM);
10574 resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10575 if (resspec == NULL)
10576 _ckvmssts_noperl(SS$_INSFMEM);
10578 /* Make a copy for modification */
10579 cmdlen = strlen(incmd);
10580 cmd = (char *)PerlMem_malloc(cmdlen+1);
10581 if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10582 my_strlcpy(cmd, incmd, cmdlen + 1);
10586 resdsc.dsc$a_pointer = resspec;
10587 resdsc.dsc$b_dtype = DSC$K_DTYPE_T;
10588 resdsc.dsc$b_class = DSC$K_CLASS_S;
10589 resdsc.dsc$w_length = VMS_MAXRSS - 1;
10591 vmscmd->dsc$a_pointer = NULL;
10592 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
10593 vmscmd->dsc$b_class = DSC$K_CLASS_S;
10594 vmscmd->dsc$w_length = 0;
10595 if (pvmscmd) *pvmscmd = vmscmd;
10597 if (suggest_quote) *suggest_quote = 0;
10599 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10601 PerlMem_free(vmsspec);
10602 PerlMem_free(resspec);
10603 return CLI$_BUFOVF; /* continuation lines currently unsupported */
10608 while (*s && isspace(*s)) s++;
10610 if (*s == '@' || *s == '$') {
10611 vmsspec[0] = *s; rest = s + 1;
10612 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10614 else { cp = vmsspec; rest = s; }
10616 /* If the first word is quoted, then we need to unquote it and
10617 * escape spaces within it. We'll expand into the resspec buffer,
10618 * then copy back into the cmd buffer, expanding the latter if
10621 if (*rest == '"') {
10626 int soff = s - cmd;
10628 for (cp2 = resspec;
10629 *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10632 if (*rest == ' ') { /* Escape ' ' to '^_'. */
10638 else if (*rest == '"') {
10640 if (in_quote) { /* Must be closing quote. */
10653 /* Expand the command buffer if necessary. */
10654 if (clen > cmdlen) {
10655 cmd = (char *)PerlMem_realloc(cmd, clen);
10657 _ckvmssts_noperl(SS$_INSFMEM);
10658 /* Where we are may have changed, so recompute offsets */
10659 r = cmd + (r - s - soff);
10660 rest = cmd + (rest - s - soff);
10664 /* Shift the non-verb portion of the command (if any) up or
10665 * down as necessary.
10668 memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10670 /* Copy the unquoted and escaped command verb into place. */
10671 memcpy(r, resspec, cp2 - resspec);
10674 rest = r; /* Rewind for subsequent operations. */
10677 if (*rest == '.' || *rest == '/') {
10679 for (cp2 = resspec;
10680 *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10681 rest++, cp2++) *cp2 = *rest;
10683 if (int_tovmsspec(resspec, cp, 0, NULL)) {
10686 /* When a UNIX spec with no file type is translated to VMS, */
10687 /* A trailing '.' is appended under ODS-5 rules. */
10688 /* Here we do not want that trailing "." as it prevents */
10689 /* Looking for a implied ".exe" type. */
10690 if (decc_efs_charset) {
10692 i = strlen(vmsspec);
10693 if (vmsspec[i-1] == '.') {
10694 vmsspec[i-1] = '\0';
10699 for (cp2 = vmsspec + strlen(vmsspec);
10700 *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10701 rest++, cp2++) *cp2 = *rest;
10706 /* Intuit whether verb (first word of cmd) is a DCL command:
10707 * - if first nonspace char is '@', it's a DCL indirection
10709 * - if verb contains a filespec separator, it's not a DCL command
10710 * - if it doesn't, caller tells us whether to default to a DCL
10711 * command, or to a local image unless told it's DCL (by leading '$')
10715 if (suggest_quote) *suggest_quote = 1;
10717 char *filespec = strpbrk(s,":<[.;");
10718 rest = wordbreak = strpbrk(s," \"\t/");
10719 if (!wordbreak) wordbreak = s + strlen(s);
10720 if (*s == '$') check_img = 0;
10721 if (filespec && (filespec < wordbreak)) isdcl = 0;
10722 else isdcl = !check_img;
10727 imgdsc.dsc$a_pointer = s;
10728 imgdsc.dsc$w_length = wordbreak - s;
10729 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10731 _ckvmssts_noperl(lib$find_file_end(&cxt));
10732 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10733 if (!(retsts & 1) && *s == '$') {
10734 _ckvmssts_noperl(lib$find_file_end(&cxt));
10735 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10736 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10738 _ckvmssts_noperl(lib$find_file_end(&cxt));
10739 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10743 _ckvmssts_noperl(lib$find_file_end(&cxt));
10748 while (*s && !isspace(*s)) s++;
10751 /* check that it's really not DCL with no file extension */
10752 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10754 char b[256] = {0,0,0,0};
10755 read(fileno(fp), b, 256);
10756 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10760 /* Check for script */
10762 if ((b[0] == '#') && (b[1] == '!'))
10764 #ifdef ALTERNATE_SHEBANG
10766 shebang_len = strlen(ALTERNATE_SHEBANG);
10767 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10769 perlstr = strstr("perl",b);
10770 if (perlstr == NULL)
10778 if (shebang_len > 0) {
10781 char tmpspec[NAM$C_MAXRSS + 1];
10784 /* Image is following after white space */
10785 /*--------------------------------------*/
10786 while (isprint(b[i]) && isspace(b[i]))
10790 while (isprint(b[i]) && !isspace(b[i])) {
10791 tmpspec[j++] = b[i++];
10792 if (j >= NAM$C_MAXRSS)
10797 /* There may be some default parameters to the image */
10798 /*---------------------------------------------------*/
10800 while (isprint(b[i])) {
10801 image_argv[j++] = b[i++];
10802 if (j >= NAM$C_MAXRSS)
10805 while ((j > 0) && !isprint(image_argv[j-1]))
10809 /* It will need to be converted to VMS format and validated */
10810 if (tmpspec[0] != '\0') {
10813 /* Try to find the exact program requested to be run */
10814 /*---------------------------------------------------*/
10815 iname = int_rmsexpand
10816 (tmpspec, image_name, ".exe",
10817 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10818 if (iname != NULL) {
10819 if (cando_by_name_int
10820 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10821 /* MCR prefix needed */
10825 /* Try again with a null type */
10826 /*----------------------------*/
10827 iname = int_rmsexpand
10828 (tmpspec, image_name, ".",
10829 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10830 if (iname != NULL) {
10831 if (cando_by_name_int
10832 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10833 /* MCR prefix needed */
10839 /* Did we find the image to run the script? */
10840 /*------------------------------------------*/
10844 /* Assume DCL or foreign command exists */
10845 /*--------------------------------------*/
10846 tchr = strrchr(tmpspec, '/');
10847 if (tchr != NULL) {
10853 my_strlcpy(image_name, tchr, sizeof(image_name));
10861 if (check_img && isdcl) {
10863 PerlMem_free(resspec);
10864 PerlMem_free(vmsspec);
10868 if (cando_by_name(S_IXUSR,0,resspec)) {
10869 vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10870 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10872 my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10873 if (image_name[0] != 0) {
10874 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10875 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10877 } else if (image_name[0] != 0) {
10878 my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10879 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10881 my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10883 if (suggest_quote) *suggest_quote = 1;
10885 /* If there is an image name, use original command */
10886 if (image_name[0] == 0)
10887 my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10890 while (*rest && isspace(*rest)) rest++;
10893 if (image_argv[0] != 0) {
10894 my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10895 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10901 rest_len = strlen(rest);
10902 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10903 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10904 my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10906 retsts = CLI$_BUFOVF;
10908 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10910 PerlMem_free(vmsspec);
10911 PerlMem_free(resspec);
10912 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10918 /* It's either a DCL command or we couldn't find a suitable image */
10919 vmscmd->dsc$w_length = strlen(cmd);
10921 vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10922 my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10925 PerlMem_free(resspec);
10926 PerlMem_free(vmsspec);
10928 /* check if it's a symbol (for quoting purposes) */
10929 if (suggest_quote && !*suggest_quote) {
10931 char equiv[LNM$C_NAMLENGTH];
10932 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10933 eqvdsc.dsc$a_pointer = equiv;
10935 iss = lib$get_symbol(vmscmd,&eqvdsc);
10936 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10938 if (!(retsts & 1)) {
10939 /* just hand off status values likely to be due to user error */
10940 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10941 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10942 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10943 else { _ckvmssts_noperl(retsts); }
10946 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10948 } /* end of setup_cmddsc() */
10951 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10953 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10959 if (vfork_called) { /* this follows a vfork - act Unixish */
10961 if (vfork_called < 0) {
10962 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10965 else return do_aexec(really,mark,sp);
10967 /* no vfork - act VMSish */
10968 cmd = setup_argstr(aTHX_ really,mark,sp);
10969 exec_sts = vms_do_exec(cmd);
10970 Safefree(cmd); /* Clean up from setup_argstr() */
10975 } /* end of vms_do_aexec() */
10978 /* {{{bool vms_do_exec(char *cmd) */
10980 Perl_vms_do_exec(pTHX_ const char *cmd)
10982 struct dsc$descriptor_s *vmscmd;
10984 if (vfork_called) { /* this follows a vfork - act Unixish */
10986 if (vfork_called < 0) {
10987 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10990 else return do_exec(cmd);
10993 { /* no vfork - act VMSish */
10994 unsigned long int retsts;
10997 TAINT_PROPER("exec");
10998 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10999 retsts = lib$do_command(vmscmd);
11002 case RMS$_FNF: case RMS$_DNF:
11003 set_errno(ENOENT); break;
11005 set_errno(ENOTDIR); break;
11007 set_errno(ENODEV); break;
11009 set_errno(EACCES); break;
11011 set_errno(EINVAL); break;
11012 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11013 set_errno(E2BIG); break;
11014 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11015 _ckvmssts_noperl(retsts); /* fall through */
11016 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11017 set_errno(EVMSERR);
11019 set_vaxc_errno(retsts);
11020 if (ckWARN(WARN_EXEC)) {
11021 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
11022 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
11024 vms_execfree(vmscmd);
11029 } /* end of vms_do_exec() */
11032 int do_spawn2(pTHX_ const char *, int);
11035 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11037 unsigned long int sts;
11043 /* We'll copy the (undocumented?) Win32 behavior and allow a
11044 * numeric first argument. But the only value we'll support
11045 * through do_aspawn is a value of 1, which means spawn without
11046 * waiting for completion -- other values are ignored.
11048 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11050 flags = SvIVx(*mark);
11053 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
11054 flags = CLI$M_NOWAIT;
11058 cmd = setup_argstr(aTHX_ really, mark, sp);
11059 sts = do_spawn2(aTHX_ cmd, flags);
11060 /* pp_sys will clean up cmd */
11064 } /* end of do_aspawn() */
11068 /* {{{int do_spawn(char* cmd) */
11070 Perl_do_spawn(pTHX_ char* cmd)
11072 PERL_ARGS_ASSERT_DO_SPAWN;
11074 return do_spawn2(aTHX_ cmd, 0);
11078 /* {{{int do_spawn_nowait(char* cmd) */
11080 Perl_do_spawn_nowait(pTHX_ char* cmd)
11082 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11084 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11088 /* {{{int do_spawn2(char *cmd) */
11090 do_spawn2(pTHX_ const char *cmd, int flags)
11092 unsigned long int sts, substs;
11094 /* The caller of this routine expects to Safefree(PL_Cmd) */
11095 Newx(PL_Cmd,10,char);
11098 TAINT_PROPER("spawn");
11099 if (!cmd || !*cmd) {
11100 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11103 case RMS$_FNF: case RMS$_DNF:
11104 set_errno(ENOENT); break;
11106 set_errno(ENOTDIR); break;
11108 set_errno(ENODEV); break;
11110 set_errno(EACCES); break;
11112 set_errno(EINVAL); break;
11113 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11114 set_errno(E2BIG); break;
11115 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11116 _ckvmssts_noperl(sts); /* fall through */
11117 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11118 set_errno(EVMSERR);
11120 set_vaxc_errno(sts);
11121 if (ckWARN(WARN_EXEC)) {
11122 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11131 if (flags & CLI$M_NOWAIT)
11134 strcpy(mode, "nW");
11136 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11139 /* sts will be the pid in the nowait case, so leave a
11140 * hint saying not to do any bit shifting to it.
11142 if (flags & CLI$M_NOWAIT)
11143 PL_statusvalue = -1;
11146 } /* end of do_spawn2() */
11150 static unsigned int *sockflags, sockflagsize;
11153 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11154 * routines found in some versions of the CRTL can't deal with sockets.
11155 * We don't shim the other file open routines since a socket isn't
11156 * likely to be opened by a name.
11158 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11160 my_fdopen(int fd, const char *mode)
11162 FILE *fp = fdopen(fd, mode);
11165 unsigned int fdoff = fd / sizeof(unsigned int);
11166 Stat_t sbuf; /* native stat; we don't need flex_stat */
11167 if (!sockflagsize || fdoff > sockflagsize) {
11168 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
11169 else Newx (sockflags,fdoff+2,unsigned int);
11170 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11171 sockflagsize = fdoff + 2;
11173 if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11174 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11183 * Clear the corresponding bit when the (possibly) socket stream is closed.
11184 * There still a small hole: we miss an implicit close which might occur
11185 * via freopen(). >> Todo
11187 /*{{{ int my_fclose(FILE *fp)*/
11189 my_fclose(FILE *fp) {
11191 unsigned int fd = fileno(fp);
11192 unsigned int fdoff = fd / sizeof(unsigned int);
11194 if (sockflagsize && fdoff < sockflagsize)
11195 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11203 * A simple fwrite replacement which outputs itmsz*nitm chars without
11204 * introducing record boundaries every itmsz chars.
11205 * We are using fputs, which depends on a terminating null. We may
11206 * well be writing binary data, so we need to accommodate not only
11207 * data with nulls sprinkled in the middle but also data with no null
11210 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11212 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11214 char *cp, *end, *cpd;
11216 unsigned int fd = fileno(dest);
11217 unsigned int fdoff = fd / sizeof(unsigned int);
11219 int bufsize = itmsz * nitm + 1;
11221 if (fdoff < sockflagsize &&
11222 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11223 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11227 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11228 memcpy( data, src, itmsz*nitm );
11229 data[itmsz*nitm] = '\0';
11231 end = data + itmsz * nitm;
11232 retval = (int) nitm; /* on success return # items written */
11235 while (cpd <= end) {
11236 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11237 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11239 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11243 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11246 } /* end of my_fwrite() */
11249 /*{{{ int my_flush(FILE *fp)*/
11251 Perl_my_flush(pTHX_ FILE *fp)
11254 if ((res = fflush(fp)) == 0 && fp) {
11255 #ifdef VMS_DO_SOCKETS
11257 if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11259 res = fsync(fileno(fp));
11262 * If the flush succeeded but set end-of-file, we need to clear
11263 * the error because our caller may check ferror(). BTW, this
11264 * probably means we just flushed an empty file.
11266 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11272 /* fgetname() is not returning the correct file specifications when
11273 * decc_filename_unix_report mode is active. So we have to have it
11274 * aways return filenames in VMS mode and convert it ourselves.
11277 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11279 Perl_my_fgetname(FILE *fp, char * buf) {
11283 retname = fgetname(fp, buf, 1);
11285 /* If we are in VMS mode, then we are done */
11286 if (!decc_filename_unix_report || (retname == NULL)) {
11290 /* Convert this to Unix format */
11291 vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11292 my_strlcpy(vms_name, retname, VMS_MAXRSS);
11293 retname = int_tounixspec(vms_name, buf, NULL);
11294 PerlMem_free(vms_name);
11301 * Here are replacements for the following Unix routines in the VMS environment:
11302 * getpwuid Get information for a particular UIC or UID
11303 * getpwnam Get information for a named user
11304 * getpwent Get information for each user in the rights database
11305 * setpwent Reset search to the start of the rights database
11306 * endpwent Finish searching for users in the rights database
11308 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11309 * (defined in pwd.h), which contains the following fields:-
11311 * char *pw_name; Username (in lower case)
11312 * char *pw_passwd; Hashed password
11313 * unsigned int pw_uid; UIC
11314 * unsigned int pw_gid; UIC group number
11315 * char *pw_unixdir; Default device/directory (VMS-style)
11316 * char *pw_gecos; Owner name
11317 * char *pw_dir; Default device/directory (Unix-style)
11318 * char *pw_shell; Default CLI name (eg. DCL)
11320 * If the specified user does not exist, getpwuid and getpwnam return NULL.
11322 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11323 * not the UIC member number (eg. what's returned by getuid()),
11324 * getpwuid() can accept either as input (if uid is specified, the caller's
11325 * UIC group is used), though it won't recognise gid=0.
11327 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11328 * information about other users in your group or in other groups, respectively.
11329 * If the required privilege is not available, then these routines fill only
11330 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11333 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11336 /* sizes of various UAF record fields */
11337 #define UAI$S_USERNAME 12
11338 #define UAI$S_IDENT 31
11339 #define UAI$S_OWNER 31
11340 #define UAI$S_DEFDEV 31
11341 #define UAI$S_DEFDIR 63
11342 #define UAI$S_DEFCLI 31
11343 #define UAI$S_PWD 8
11345 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
11346 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11347 (uic).uic$v_group != UIC$K_WILD_GROUP)
11349 static char __empty[]= "";
11350 static struct passwd __passwd_empty=
11351 {(char *) __empty, (char *) __empty, 0, 0,
11352 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11353 static int contxt= 0;
11354 static struct passwd __pwdcache;
11355 static char __pw_namecache[UAI$S_IDENT+1];
11358 * This routine does most of the work extracting the user information.
11361 fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11364 unsigned char length;
11365 char pw_gecos[UAI$S_OWNER+1];
11367 static union uicdef uic;
11369 unsigned char length;
11370 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11373 unsigned char length;
11374 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11377 unsigned char length;
11378 char pw_shell[UAI$S_DEFCLI+1];
11380 static char pw_passwd[UAI$S_PWD+1];
11382 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11383 struct dsc$descriptor_s name_desc;
11384 unsigned long int sts;
11386 static struct itmlst_3 itmlst[]= {
11387 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
11388 {sizeof(uic), UAI$_UIC, &uic, &luic},
11389 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
11390 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
11391 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
11392 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
11393 {0, 0, NULL, NULL}};
11395 name_desc.dsc$w_length= strlen(name);
11396 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11397 name_desc.dsc$b_class= DSC$K_CLASS_S;
11398 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11400 /* Note that sys$getuai returns many fields as counted strings. */
11401 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11402 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11403 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11405 else { _ckvmssts(sts); }
11406 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
11408 if ((int) owner.length < lowner) lowner= (int) owner.length;
11409 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11410 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11411 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11412 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11413 owner.pw_gecos[lowner]= '\0';
11414 defdev.pw_dir[ldefdev+ldefdir]= '\0';
11415 defcli.pw_shell[ldefcli]= '\0';
11416 if (valid_uic(uic)) {
11417 pwd->pw_uid= uic.uic$l_uic;
11418 pwd->pw_gid= uic.uic$v_group;
11421 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11422 pwd->pw_passwd= pw_passwd;
11423 pwd->pw_gecos= owner.pw_gecos;
11424 pwd->pw_dir= defdev.pw_dir;
11425 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11426 pwd->pw_shell= defcli.pw_shell;
11427 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11429 ldir= strlen(pwd->pw_unixdir) - 1;
11430 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11433 my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11434 if (!decc_efs_case_preserve)
11435 __mystrtolower(pwd->pw_unixdir);
11440 * Get information for a named user.
11442 /*{{{struct passwd *getpwnam(char *name)*/
11444 Perl_my_getpwnam(pTHX_ const char *name)
11446 struct dsc$descriptor_s name_desc;
11448 unsigned long int sts;
11450 __pwdcache = __passwd_empty;
11451 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11452 /* We still may be able to determine pw_uid and pw_gid */
11453 name_desc.dsc$w_length= strlen(name);
11454 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11455 name_desc.dsc$b_class= DSC$K_CLASS_S;
11456 name_desc.dsc$a_pointer= (char *) name;
11457 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11458 __pwdcache.pw_uid= uic.uic$l_uic;
11459 __pwdcache.pw_gid= uic.uic$v_group;
11462 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11463 set_vaxc_errno(sts);
11464 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11467 else { _ckvmssts(sts); }
11470 my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11471 __pwdcache.pw_name= __pw_namecache;
11472 return &__pwdcache;
11473 } /* end of my_getpwnam() */
11477 * Get information for a particular UIC or UID.
11478 * Called by my_getpwent with uid=-1 to list all users.
11480 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11482 Perl_my_getpwuid(pTHX_ Uid_t uid)
11484 const $DESCRIPTOR(name_desc,__pw_namecache);
11485 unsigned short lname;
11487 unsigned long int status;
11489 if (uid == (unsigned int) -1) {
11491 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11492 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11493 set_vaxc_errno(status);
11494 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11498 else { _ckvmssts(status); }
11499 } while (!valid_uic (uic));
11502 uic.uic$l_uic= uid;
11503 if (!uic.uic$v_group)
11504 uic.uic$v_group= PerlProc_getgid();
11505 if (valid_uic(uic))
11506 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11507 else status = SS$_IVIDENT;
11508 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11509 status == RMS$_PRV) {
11510 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11513 else { _ckvmssts(status); }
11515 __pw_namecache[lname]= '\0';
11516 __mystrtolower(__pw_namecache);
11518 __pwdcache = __passwd_empty;
11519 __pwdcache.pw_name = __pw_namecache;
11521 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11522 The identifier's value is usually the UIC, but it doesn't have to be,
11523 so if we can, we let fillpasswd update this. */
11524 __pwdcache.pw_uid = uic.uic$l_uic;
11525 __pwdcache.pw_gid = uic.uic$v_group;
11527 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11528 return &__pwdcache;
11530 } /* end of my_getpwuid() */
11534 * Get information for next user.
11536 /*{{{struct passwd *my_getpwent()*/
11538 Perl_my_getpwent(pTHX)
11540 return (my_getpwuid((unsigned int) -1));
11545 * Finish searching rights database for users.
11547 /*{{{void my_endpwent()*/
11549 Perl_my_endpwent(pTHX)
11552 _ckvmssts(sys$finish_rdb(&contxt));
11558 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11559 * my_utime(), and flex_stat(), all of which operate on UTC unless
11560 * VMSISH_TIMES is true.
11562 /* method used to handle UTC conversions:
11563 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
11565 static int gmtime_emulation_type;
11566 /* number of secs to add to UTC POSIX-style time to get local time */
11567 static long int utc_offset_secs;
11569 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11570 * in vmsish.h. #undef them here so we can call the CRTL routines
11578 static time_t toutc_dst(time_t loc) {
11581 if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11582 loc -= utc_offset_secs;
11583 if (rsltmp->tm_isdst) loc -= 3600;
11586 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11587 ((gmtime_emulation_type || my_time(NULL)), \
11588 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11589 ((secs) - utc_offset_secs))))
11591 static time_t toloc_dst(time_t utc) {
11594 utc += utc_offset_secs;
11595 if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11596 if (rsltmp->tm_isdst) utc += 3600;
11599 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11600 ((gmtime_emulation_type || my_time(NULL)), \
11601 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11602 ((secs) + utc_offset_secs))))
11604 /* my_time(), my_localtime(), my_gmtime()
11605 * By default traffic in UTC time values, using CRTL gmtime() or
11606 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11607 * Note: We need to use these functions even when the CRTL has working
11608 * UTC support, since they also handle C<use vmsish qw(times);>
11610 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
11611 * Modified by Charles Bailey <bailey@newman.upenn.edu>
11614 /*{{{time_t my_time(time_t *timep)*/
11616 Perl_my_time(pTHX_ time_t *timep)
11621 if (gmtime_emulation_type == 0) {
11622 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11623 /* results of calls to gmtime() and localtime() */
11624 /* for same &base */
11626 gmtime_emulation_type++;
11627 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11628 char off[LNM$C_NAMLENGTH+1];;
11630 gmtime_emulation_type++;
11631 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11632 gmtime_emulation_type++;
11633 utc_offset_secs = 0;
11634 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11636 else { utc_offset_secs = atol(off); }
11638 else { /* We've got a working gmtime() */
11639 struct tm gmt, local;
11642 tm_p = localtime(&base);
11644 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11645 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11646 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11647 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11652 # ifdef VMSISH_TIME
11653 if (VMSISH_TIME) when = _toloc(when);
11655 if (timep != NULL) *timep = when;
11658 } /* end of my_time() */
11662 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11664 Perl_my_gmtime(pTHX_ const time_t *timep)
11669 if (timep == NULL) {
11670 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11673 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11676 # ifdef VMSISH_TIME
11677 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11679 return gmtime(&when);
11680 } /* end of my_gmtime() */
11684 /*{{{struct tm *my_localtime(const time_t *timep)*/
11686 Perl_my_localtime(pTHX_ const time_t *timep)
11690 if (timep == NULL) {
11691 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11694 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11695 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11698 # ifdef VMSISH_TIME
11699 if (VMSISH_TIME) when = _toutc(when);
11701 /* CRTL localtime() wants UTC as input, does tz correction itself */
11702 return localtime(&when);
11703 } /* end of my_localtime() */
11706 /* Reset definitions for later calls */
11707 #define gmtime(t) my_gmtime(t)
11708 #define localtime(t) my_localtime(t)
11709 #define time(t) my_time(t)
11712 /* my_utime - update modification/access time of a file
11714 * Only the UTC translation is home-grown. The rest is handled by the
11715 * CRTL utime(), which will take into account the relevant feature
11716 * logicals and ODS-5 volume characteristics for true access times.
11720 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11721 * to VMS epoch (01-JAN-1858 00:00:00.00)
11722 * in 100 ns intervals.
11724 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11726 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11728 Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11730 struct utimbuf utc_utimes, *utc_utimesp;
11732 if (utimes != NULL) {
11733 utc_utimes.actime = utimes->actime;
11734 utc_utimes.modtime = utimes->modtime;
11735 # ifdef VMSISH_TIME
11736 /* If input was local; convert to UTC for sys svc */
11738 utc_utimes.actime = _toutc(utimes->actime);
11739 utc_utimes.modtime = _toutc(utimes->modtime);
11742 utc_utimesp = &utc_utimes;
11745 utc_utimesp = NULL;
11748 return utime(file, utc_utimesp);
11750 } /* end of my_utime() */
11754 * flex_stat, flex_lstat, flex_fstat
11755 * basic stat, but gets it right when asked to stat
11756 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11759 #ifndef _USE_STD_STAT
11760 /* encode_dev packs a VMS device name string into an integer to allow
11761 * simple comparisons. This can be used, for example, to check whether two
11762 * files are located on the same device, by comparing their encoded device
11763 * names. Even a string comparison would not do, because stat() reuses the
11764 * device name buffer for each call; so without encode_dev, it would be
11765 * necessary to save the buffer and use strcmp (this would mean a number of
11766 * changes to the standard Perl code, to say nothing of what a Perl script
11767 * would have to do.
11769 * The device lock id, if it exists, should be unique (unless perhaps compared
11770 * with lock ids transferred from other nodes). We have a lock id if the disk is
11771 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11772 * device names. Thus we use the lock id in preference, and only if that isn't
11773 * available, do we try to pack the device name into an integer (flagged by
11774 * the sign bit (LOCKID_MASK) being set).
11776 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11777 * name and its encoded form, but it seems very unlikely that we will find
11778 * two files on different disks that share the same encoded device names,
11779 * and even more remote that they will share the same file id (if the test
11780 * is to check for the same file).
11782 * A better method might be to use sys$device_scan on the first call, and to
11783 * search for the device, returning an index into the cached array.
11784 * The number returned would be more intelligible.
11785 * This is probably not worth it, and anyway would take quite a bit longer
11786 * on the first call.
11788 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
11790 encode_dev (pTHX_ const char *dev)
11793 unsigned long int f;
11798 if (!dev || !dev[0]) return 0;
11802 struct dsc$descriptor_s dev_desc;
11803 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11805 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11806 can try that first. */
11807 dev_desc.dsc$w_length = strlen (dev);
11808 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11809 dev_desc.dsc$b_class = DSC$K_CLASS_S;
11810 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
11811 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11812 if (!$VMS_STATUS_SUCCESS(status)) {
11814 case SS$_NOSUCHDEV:
11815 SETERRNO(ENODEV, status);
11821 if (lockid) return (lockid & ~LOCKID_MASK);
11825 /* Otherwise we try to encode the device name */
11829 for (q = dev + strlen(dev); q--; q >= dev) {
11834 else if (isalpha (toupper (*q)))
11835 c= toupper (*q) - 'A' + (char)10;
11837 continue; /* Skip '$'s */
11839 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11841 enc += f * (unsigned long int) c;
11843 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11845 } /* end of encode_dev() */
11846 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11847 device_no = encode_dev(aTHX_ devname)
11849 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11850 device_no = new_dev_no
11854 is_null_device(const char *name)
11856 if (decc_bug_devnull != 0) {
11857 if (strncmp("/dev/null", name, 9) == 0)
11860 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11861 The underscore prefix, controller letter, and unit number are
11862 independently optional; for our purposes, the colon punctuation
11863 is not. The colon can be trailed by optional directory and/or
11864 filename, but two consecutive colons indicates a nodename rather
11865 than a device. [pr] */
11866 if (*name == '_') ++name;
11867 if (tolower(*name++) != 'n') return 0;
11868 if (tolower(*name++) != 'l') return 0;
11869 if (tolower(*name) == 'a') ++name;
11870 if (*name == '0') ++name;
11871 return (*name++ == ':') && (*name != ':');
11875 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11877 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11880 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective, const char *fname, int opts)
11882 char usrname[L_cuserid];
11883 struct dsc$descriptor_s usrdsc =
11884 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11885 char *vmsname = NULL, *fileified = NULL;
11886 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11887 unsigned short int retlen, trnlnm_iter_count;
11888 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11889 union prvdef curprv;
11890 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11891 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11892 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11893 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11894 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11896 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11898 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11900 static int profile_context = -1;
11902 if (!fname || !*fname) return FALSE;
11904 /* Make sure we expand logical names, since sys$check_access doesn't */
11905 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11906 if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11907 if (!strpbrk(fname,"/]>:")) {
11908 my_strlcpy(fileified, fname, VMS_MAXRSS);
11909 trnlnm_iter_count = 0;
11910 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11911 trnlnm_iter_count++;
11912 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11917 vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11918 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11919 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11920 /* Don't know if already in VMS format, so make sure */
11921 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11922 PerlMem_free(fileified);
11923 PerlMem_free(vmsname);
11928 my_strlcpy(vmsname, fname, VMS_MAXRSS);
11931 /* sys$check_access needs a file spec, not a directory spec.
11932 * flex_stat now will handle a null thread context during startup.
11935 retlen = namdsc.dsc$w_length = strlen(vmsname);
11936 if (vmsname[retlen-1] == ']'
11937 || vmsname[retlen-1] == '>'
11938 || vmsname[retlen-1] == ':'
11939 || (!flex_stat_int(vmsname, &st, 1) &&
11940 S_ISDIR(st.st_mode))) {
11942 if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11943 PerlMem_free(fileified);
11944 PerlMem_free(vmsname);
11953 retlen = namdsc.dsc$w_length = strlen(fname);
11954 namdsc.dsc$a_pointer = (char *)fname;
11957 case S_IXUSR: case S_IXGRP: case S_IXOTH:
11958 access = ARM$M_EXECUTE;
11959 flags = CHP$M_READ;
11961 case S_IRUSR: case S_IRGRP: case S_IROTH:
11962 access = ARM$M_READ;
11963 flags = CHP$M_READ | CHP$M_USEREADALL;
11965 case S_IWUSR: case S_IWGRP: case S_IWOTH:
11966 access = ARM$M_WRITE;
11967 flags = CHP$M_READ | CHP$M_WRITE;
11969 case S_IDUSR: case S_IDGRP: case S_IDOTH:
11970 access = ARM$M_DELETE;
11971 flags = CHP$M_READ | CHP$M_WRITE;
11974 if (fileified != NULL)
11975 PerlMem_free(fileified);
11976 if (vmsname != NULL)
11977 PerlMem_free(vmsname);
11981 /* Before we call $check_access, create a user profile with the current
11982 * process privs since otherwise it just uses the default privs from the
11983 * UAF and might give false positives or negatives. This only works on
11984 * VMS versions v6.0 and later since that's when sys$create_user_profile
11985 * became available.
11988 /* get current process privs and username */
11989 _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11990 _ckvmssts_noperl(iosb[0]);
11992 /* find out the space required for the profile */
11993 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11994 &usrprodsc.dsc$w_length,&profile_context));
11996 /* allocate space for the profile and get it filled in */
11997 usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
11998 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11999 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12000 &usrprodsc.dsc$w_length,&profile_context));
12002 /* use the profile to check access to the file; free profile & analyze results */
12003 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12004 PerlMem_free(usrprodsc.dsc$a_pointer);
12005 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12007 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
12008 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12009 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12010 set_vaxc_errno(retsts);
12011 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12012 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12013 else set_errno(ENOENT);
12014 if (fileified != NULL)
12015 PerlMem_free(fileified);
12016 if (vmsname != NULL)
12017 PerlMem_free(vmsname);
12020 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12021 if (fileified != NULL)
12022 PerlMem_free(fileified);
12023 if (vmsname != NULL)
12024 PerlMem_free(vmsname);
12027 _ckvmssts_noperl(retsts);
12029 if (fileified != NULL)
12030 PerlMem_free(fileified);
12031 if (vmsname != NULL)
12032 PerlMem_free(vmsname);
12033 return FALSE; /* Should never get here */
12037 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
12038 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12039 * subset of the applicable information.
12042 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12044 return cando_by_name_int
12045 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12046 } /* end of cando() */
12050 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12052 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12054 return cando_by_name_int(bit, effective, fname, 0);
12056 } /* end of cando_by_name() */
12060 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12062 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12064 dSAVE_ERRNO; /* fstat may set this even on success */
12065 if (!fstat(fd, &statbufp->crtl_stat)) {
12067 char *vms_filename;
12068 vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12069 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12071 /* Save name for cando by name in VMS format */
12072 cptr = getname(fd, vms_filename, 1);
12074 /* This should not happen, but just in case */
12075 if (cptr == NULL) {
12076 statbufp->st_devnam[0] = 0;
12079 /* Make sure that the saved name fits in 255 characters */
12080 cptr = int_rmsexpand_vms
12082 statbufp->st_devnam,
12085 statbufp->st_devnam[0] = 0;
12087 PerlMem_free(vms_filename);
12089 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12091 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12093 # ifdef VMSISH_TIME
12095 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12096 statbufp->st_atime = _toloc(statbufp->st_atime);
12097 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12105 } /* end of flex_fstat() */
12109 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12111 char *temp_fspec = NULL;
12112 char *fileified = NULL;
12113 const char *save_spec;
12117 char already_fileified = 0;
12125 if (decc_bug_devnull != 0) {
12126 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12127 memset(statbufp,0,sizeof *statbufp);
12128 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12129 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12130 statbufp->st_uid = 0x00010001;
12131 statbufp->st_gid = 0x0001;
12132 time((time_t *)&statbufp->st_mtime);
12133 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12140 #if __CRTL_VER >= 80200000
12142 * If we are in POSIX filespec mode, accept the filename as is.
12144 if (decc_posix_compliant_pathnames == 0) {
12147 /* Try for a simple stat first. If fspec contains a filename without
12148 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12149 * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12150 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12151 * not sea:[wine.dark]., if the latter exists. If the intended target is
12152 * the file with null type, specify this by calling flex_stat() with
12153 * a '.' at the end of fspec.
12156 if (lstat_flag == 0)
12157 retval = stat(fspec, &statbufp->crtl_stat);
12159 retval = lstat(fspec, &statbufp->crtl_stat);
12165 /* In the odd case where we have write but not read access
12166 * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12168 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12169 if (fileified == NULL)
12170 _ckvmssts_noperl(SS$_INSFMEM);
12172 ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12173 if (ret_spec != NULL) {
12174 if (lstat_flag == 0)
12175 retval = stat(fileified, &statbufp->crtl_stat);
12177 retval = lstat(fileified, &statbufp->crtl_stat);
12178 save_spec = fileified;
12179 already_fileified = 1;
12183 if (retval && vms_bug_stat_filename) {
12185 temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12186 if (temp_fspec == NULL)
12187 _ckvmssts_noperl(SS$_INSFMEM);
12189 /* We should try again as a vmsified file specification. */
12191 ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12192 if (ret_spec != NULL) {
12193 if (lstat_flag == 0)
12194 retval = stat(temp_fspec, &statbufp->crtl_stat);
12196 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12197 save_spec = temp_fspec;
12202 /* Last chance - allow multiple dots without EFS CHARSET */
12203 /* The CRTL stat() falls down hard on multi-dot filenames in unix
12204 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12205 * enable it if it isn't already.
12207 if (!decc_efs_charset && (decc_efs_charset_index > 0))
12208 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12209 if (lstat_flag == 0)
12210 retval = stat(fspec, &statbufp->crtl_stat);
12212 retval = lstat(fspec, &statbufp->crtl_stat);
12214 if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12215 decc$feature_set_value(decc_efs_charset_index, 1, 0);
12220 #if __CRTL_VER >= 80200000
12222 if (lstat_flag == 0)
12223 retval = stat(temp_fspec, &statbufp->crtl_stat);
12225 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12226 save_spec = temp_fspec;
12230 /* As you were... */
12231 if (!decc_efs_charset)
12232 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12236 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12238 /* If this is an lstat, do not follow the link */
12240 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12242 /* If we used the efs_hack above, we must also use it here for */
12243 /* perl_cando to work */
12244 if (efs_hack && (decc_efs_charset_index > 0)) {
12245 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12248 /* If we've got a directory, save a fileified, expanded version of it
12249 * in st_devnam. If not a directory, just an expanded version.
12251 if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12252 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12253 if (fileified == NULL)
12254 _ckvmssts_noperl(SS$_INSFMEM);
12256 cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12258 save_spec = fileified;
12261 cptr = int_rmsexpand(save_spec,
12262 statbufp->st_devnam,
12268 if (efs_hack && (decc_efs_charset_index > 0)) {
12269 decc$feature_set_value(decc_efs_charset, 1, 0);
12272 /* Fix me: If this is NULL then stat found a file, and we could */
12273 /* not convert the specification to VMS - Should never happen */
12275 statbufp->st_devnam[0] = 0;
12277 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12279 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12280 # ifdef VMSISH_TIME
12282 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12283 statbufp->st_atime = _toloc(statbufp->st_atime);
12284 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12288 /* If we were successful, leave errno where we found it */
12289 if (retval == 0) RESTORE_ERRNO;
12291 PerlMem_free(temp_fspec);
12293 PerlMem_free(fileified);
12296 } /* end of flex_stat_int() */
12299 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12301 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12303 return flex_stat_int(fspec, statbufp, 0);
12307 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12309 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12311 return flex_stat_int(fspec, statbufp, 1);
12316 /* rmscopy - copy a file using VMS RMS routines
12318 * Copies contents and attributes of spec_in to spec_out, except owner
12319 * and protection information. Name and type of spec_in are used as
12320 * defaults for spec_out. The third parameter specifies whether rmscopy()
12321 * should try to propagate timestamps from the input file to the output file.
12322 * If it is less than 0, no timestamps are preserved. If it is 0, then
12323 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12324 * propagated to the output file at creation iff the output file specification
12325 * did not contain an explicit name or type, and the revision date is always
12326 * updated at the end of the copy operation. If it is greater than 0, then
12327 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12328 * other than the revision date should be propagated, and bit 1 indicates
12329 * that the revision date should be propagated.
12331 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12333 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12334 * Incorporates, with permission, some code from EZCOPY by Tim Adye
12335 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12336 * as part of the Perl standard distribution under the terms of the
12337 * GNU General Public License or the Perl Artistic License. Copies
12338 * of each may be found in the Perl standard distribution.
12340 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12342 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12344 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12345 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12346 unsigned long int sts;
12348 struct FAB fab_in, fab_out;
12349 struct RAB rab_in, rab_out;
12350 rms_setup_nam(nam);
12351 rms_setup_nam(nam_out);
12352 struct XABDAT xabdat;
12353 struct XABFHC xabfhc;
12354 struct XABRDT xabrdt;
12355 struct XABSUM xabsum;
12357 vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12358 if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12359 vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12360 if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12361 if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12362 !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12363 PerlMem_free(vmsin);
12364 PerlMem_free(vmsout);
12365 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12369 esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12370 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12372 #if defined(NAML$C_MAXRSS)
12373 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12374 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12376 fab_in = cc$rms_fab;
12377 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12378 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12379 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12380 fab_in.fab$l_fop = FAB$M_SQO;
12381 rms_bind_fab_nam(fab_in, nam);
12382 fab_in.fab$l_xab = (void *) &xabdat;
12384 rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12385 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12387 #if defined(NAML$C_MAXRSS)
12388 rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12389 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12391 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12392 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12393 rms_nam_esl(nam) = 0;
12394 rms_nam_rsl(nam) = 0;
12395 rms_nam_esll(nam) = 0;
12396 rms_nam_rsll(nam) = 0;
12397 #ifdef NAM$M_NO_SHORT_UPCASE
12398 if (decc_efs_case_preserve)
12399 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12402 xabdat = cc$rms_xabdat; /* To get creation date */
12403 xabdat.xab$l_nxt = (void *) &xabfhc;
12405 xabfhc = cc$rms_xabfhc; /* To get record length */
12406 xabfhc.xab$l_nxt = (void *) &xabsum;
12408 xabsum = cc$rms_xabsum; /* To get key and area information */
12410 if (!((sts = sys$open(&fab_in)) & 1)) {
12411 PerlMem_free(vmsin);
12412 PerlMem_free(vmsout);
12415 PerlMem_free(esal);
12418 PerlMem_free(rsal);
12419 set_vaxc_errno(sts);
12421 case RMS$_FNF: case RMS$_DNF:
12422 set_errno(ENOENT); break;
12424 set_errno(ENOTDIR); break;
12426 set_errno(ENODEV); break;
12428 set_errno(EINVAL); break;
12430 set_errno(EACCES); break;
12432 set_errno(EVMSERR);
12439 fab_out.fab$w_ifi = 0;
12440 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12441 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12442 fab_out.fab$l_fop = FAB$M_SQO;
12443 rms_bind_fab_nam(fab_out, nam_out);
12444 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12445 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12446 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12447 esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12448 if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12449 rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12450 if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12453 #if defined(NAML$C_MAXRSS)
12454 esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12455 if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12456 rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12457 if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12459 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12460 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12462 if (preserve_dates == 0) { /* Act like DCL COPY */
12463 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12464 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
12465 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12466 PerlMem_free(vmsin);
12467 PerlMem_free(vmsout);
12470 PerlMem_free(esal);
12473 PerlMem_free(rsal);
12474 PerlMem_free(esa_out);
12475 if (esal_out != NULL)
12476 PerlMem_free(esal_out);
12477 PerlMem_free(rsa_out);
12478 if (rsal_out != NULL)
12479 PerlMem_free(rsal_out);
12480 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12481 set_vaxc_errno(sts);
12484 fab_out.fab$l_xab = (void *) &xabdat;
12485 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12486 preserve_dates = 1;
12488 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12489 preserve_dates =0; /* bitmask from this point forward */
12491 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12492 if (!((sts = sys$create(&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_vaxc_errno(sts);
12510 set_errno(ENOENT); break;
12512 set_errno(ENOTDIR); break;
12514 set_errno(ENODEV); break;
12516 set_errno(EINVAL); break;
12518 set_errno(EACCES); break;
12520 set_errno(EVMSERR);
12524 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12525 if (preserve_dates & 2) {
12526 /* sys$close() will process xabrdt, not xabdat */
12527 xabrdt = cc$rms_xabrdt;
12528 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12529 fab_out.fab$l_xab = (void *) &xabrdt;
12532 ubf = (char *)PerlMem_malloc(32256);
12533 if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12534 rab_in = cc$rms_rab;
12535 rab_in.rab$l_fab = &fab_in;
12536 rab_in.rab$l_rop = RAB$M_BIO;
12537 rab_in.rab$l_ubf = ubf;
12538 rab_in.rab$w_usz = 32256;
12539 if (!((sts = sys$connect(&rab_in)) & 1)) {
12540 sys$close(&fab_in); sys$close(&fab_out);
12541 PerlMem_free(vmsin);
12542 PerlMem_free(vmsout);
12546 PerlMem_free(esal);
12549 PerlMem_free(rsal);
12550 PerlMem_free(esa_out);
12551 if (esal_out != NULL)
12552 PerlMem_free(esal_out);
12553 PerlMem_free(rsa_out);
12554 if (rsal_out != NULL)
12555 PerlMem_free(rsal_out);
12556 set_errno(EVMSERR); set_vaxc_errno(sts);
12560 rab_out = cc$rms_rab;
12561 rab_out.rab$l_fab = &fab_out;
12562 rab_out.rab$l_rbf = ubf;
12563 if (!((sts = sys$connect(&rab_out)) & 1)) {
12564 sys$close(&fab_in); sys$close(&fab_out);
12565 PerlMem_free(vmsin);
12566 PerlMem_free(vmsout);
12570 PerlMem_free(esal);
12573 PerlMem_free(rsal);
12574 PerlMem_free(esa_out);
12575 if (esal_out != NULL)
12576 PerlMem_free(esal_out);
12577 PerlMem_free(rsa_out);
12578 if (rsal_out != NULL)
12579 PerlMem_free(rsal_out);
12580 set_errno(EVMSERR); set_vaxc_errno(sts);
12584 while ((sts = sys$read(&rab_in))) { /* always true */
12585 if (sts == RMS$_EOF) break;
12586 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12587 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12588 sys$close(&fab_in); sys$close(&fab_out);
12589 PerlMem_free(vmsin);
12590 PerlMem_free(vmsout);
12594 PerlMem_free(esal);
12597 PerlMem_free(rsal);
12598 PerlMem_free(esa_out);
12599 if (esal_out != NULL)
12600 PerlMem_free(esal_out);
12601 PerlMem_free(rsa_out);
12602 if (rsal_out != NULL)
12603 PerlMem_free(rsal_out);
12604 set_errno(EVMSERR); set_vaxc_errno(sts);
12610 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12611 sys$close(&fab_in); sys$close(&fab_out);
12612 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12614 PerlMem_free(vmsin);
12615 PerlMem_free(vmsout);
12619 PerlMem_free(esal);
12622 PerlMem_free(rsal);
12623 PerlMem_free(esa_out);
12624 if (esal_out != NULL)
12625 PerlMem_free(esal_out);
12626 PerlMem_free(rsa_out);
12627 if (rsal_out != NULL)
12628 PerlMem_free(rsal_out);
12631 set_errno(EVMSERR); set_vaxc_errno(sts);
12637 } /* end of rmscopy() */
12641 /*** The following glue provides 'hooks' to make some of the routines
12642 * from this file available from Perl. These routines are sufficiently
12643 * basic, and are required sufficiently early in the build process,
12644 * that's it's nice to have them available to miniperl as well as the
12645 * full Perl, so they're set up here instead of in an extension. The
12646 * Perl code which handles importation of these names into a given
12647 * package lives in [.VMS]Filespec.pm in @INC.
12651 rmsexpand_fromperl(pTHX_ CV *cv)
12654 char *fspec, *defspec = NULL, *rslt;
12656 int fs_utf8, dfs_utf8;
12660 if (!items || items > 2)
12661 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12662 fspec = SvPV(ST(0),n_a);
12663 fs_utf8 = SvUTF8(ST(0));
12664 if (!fspec || !*fspec) XSRETURN_UNDEF;
12666 defspec = SvPV(ST(1),n_a);
12667 dfs_utf8 = SvUTF8(ST(1));
12669 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12670 ST(0) = sv_newmortal();
12671 if (rslt != NULL) {
12672 sv_usepvn(ST(0),rslt,strlen(rslt));
12681 vmsify_fromperl(pTHX_ CV *cv)
12688 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12689 utf8_fl = SvUTF8(ST(0));
12690 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12691 ST(0) = sv_newmortal();
12692 if (vmsified != NULL) {
12693 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12702 unixify_fromperl(pTHX_ CV *cv)
12709 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12710 utf8_fl = SvUTF8(ST(0));
12711 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12712 ST(0) = sv_newmortal();
12713 if (unixified != NULL) {
12714 sv_usepvn(ST(0),unixified,strlen(unixified));
12723 fileify_fromperl(pTHX_ CV *cv)
12730 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12731 utf8_fl = SvUTF8(ST(0));
12732 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12733 ST(0) = sv_newmortal();
12734 if (fileified != NULL) {
12735 sv_usepvn(ST(0),fileified,strlen(fileified));
12744 pathify_fromperl(pTHX_ CV *cv)
12751 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12752 utf8_fl = SvUTF8(ST(0));
12753 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12754 ST(0) = sv_newmortal();
12755 if (pathified != NULL) {
12756 sv_usepvn(ST(0),pathified,strlen(pathified));
12765 vmspath_fromperl(pTHX_ CV *cv)
12772 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12773 utf8_fl = SvUTF8(ST(0));
12774 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12775 ST(0) = sv_newmortal();
12776 if (vmspath != NULL) {
12777 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12786 unixpath_fromperl(pTHX_ CV *cv)
12793 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12794 utf8_fl = SvUTF8(ST(0));
12795 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12796 ST(0) = sv_newmortal();
12797 if (unixpath != NULL) {
12798 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12807 candelete_fromperl(pTHX_ CV *cv)
12815 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12817 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12818 Newx(fspec, VMS_MAXRSS, char);
12819 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12820 if (isGV_with_GP(mysv)) {
12821 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12822 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12830 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12831 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12838 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12844 rmscopy_fromperl(pTHX_ CV *cv)
12847 char *inspec, *outspec, *inp, *outp;
12853 if (items < 2 || items > 3)
12854 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12856 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12857 Newx(inspec, VMS_MAXRSS, char);
12858 if (isGV_with_GP(mysv)) {
12859 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12860 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12861 ST(0) = sv_2mortal(newSViv(0));
12868 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12869 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12870 ST(0) = sv_2mortal(newSViv(0));
12875 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12876 Newx(outspec, VMS_MAXRSS, char);
12877 if (isGV_with_GP(mysv)) {
12878 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12879 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12880 ST(0) = sv_2mortal(newSViv(0));
12888 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12889 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12890 ST(0) = sv_2mortal(newSViv(0));
12896 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12898 ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12904 /* The mod2fname is limited to shorter filenames by design, so it should
12905 * not be modified to support longer EFS pathnames
12908 mod2fname(pTHX_ CV *cv)
12911 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12912 workbuff[NAM$C_MAXRSS*1 + 1];
12913 SSize_t counter, num_entries;
12914 /* ODS-5 ups this, but we want to be consistent, so... */
12915 int max_name_len = 39;
12916 AV *in_array = (AV *)SvRV(ST(0));
12918 num_entries = av_tindex(in_array);
12920 /* All the names start with PL_. */
12921 strcpy(ultimate_name, "PL_");
12923 /* Clean up our working buffer */
12924 Zero(work_name, sizeof(work_name), char);
12926 /* Run through the entries and build up a working name */
12927 for(counter = 0; counter <= num_entries; counter++) {
12928 /* If it's not the first name then tack on a __ */
12930 my_strlcat(work_name, "__", sizeof(work_name));
12932 my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12935 /* Check to see if we actually have to bother...*/
12936 if (strlen(work_name) + 3 <= max_name_len) {
12937 my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12939 /* It's too darned big, so we need to go strip. We use the same */
12940 /* algorithm as xsubpp does. First, strip out doubled __ */
12941 char *source, *dest, last;
12944 for (source = work_name; *source; source++) {
12945 if (last == *source && last == '_') {
12951 /* Go put it back */
12952 my_strlcpy(work_name, workbuff, sizeof(work_name));
12953 /* Is it still too big? */
12954 if (strlen(work_name) + 3 > max_name_len) {
12955 /* Strip duplicate letters */
12958 for (source = work_name; *source; source++) {
12959 if (last == toupper(*source)) {
12963 last = toupper(*source);
12965 my_strlcpy(work_name, workbuff, sizeof(work_name));
12968 /* Is it *still* too big? */
12969 if (strlen(work_name) + 3 > max_name_len) {
12970 /* Too bad, we truncate */
12971 work_name[max_name_len - 2] = 0;
12973 my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12976 /* Okay, return it */
12977 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12982 hushexit_fromperl(pTHX_ CV *cv)
12987 VMSISH_HUSHED = SvTRUE(ST(0));
12989 ST(0) = boolSV(VMSISH_HUSHED);
12995 Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io)
12998 struct vs_str_st *rslt;
13002 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13005 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13006 struct dsc$descriptor_vs rsdsc;
13007 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13008 unsigned long hasver = 0, isunix = 0;
13009 unsigned long int lff_flags = 0;
13011 int vms_old_glob = 1;
13013 if (!SvOK(tmpglob)) {
13014 SETERRNO(ENOENT,RMS$_FNF);
13018 vms_old_glob = !decc_filename_unix_report;
13020 #ifdef VMS_LONGNAME_SUPPORT
13021 lff_flags = LIB$M_FIL_LONG_NAMES;
13023 /* The Newx macro will not allow me to assign a smaller array
13024 * to the rslt pointer, so we will assign it to the begin char pointer
13025 * and then copy the value into the rslt pointer.
13027 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13028 rslt = (struct vs_str_st *)begin;
13030 rstr = &rslt->str[0];
13031 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13032 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13033 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13034 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13036 Newx(vmsspec, VMS_MAXRSS, char);
13038 /* We could find out if there's an explicit dev/dir or version
13039 by peeking into lib$find_file's internal context at
13040 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13041 but that's unsupported, so I don't want to do it now and
13042 have it bite someone in the future. */
13043 /* Fix-me: vms_split_path() is the only way to do this, the
13044 existing method will fail with many legal EFS or UNIX specifications
13047 cp = SvPV(tmpglob,i);
13050 if (cp[i] == ';') hasver = 1;
13051 if (cp[i] == '.') {
13052 if (sts) hasver = 1;
13055 if (cp[i] == '/') {
13056 hasdir = isunix = 1;
13059 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13065 /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13066 if ((hasdir == 0) && decc_filename_unix_report) {
13070 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13071 char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13072 int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13078 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13079 if (!stat_sts && S_ISDIR(st.st_mode)) {
13081 const char * fname;
13084 /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13085 /* path delimiter of ':>]', if so, then the old behavior has */
13086 /* obviously been specifically requested */
13088 fname = SvPVX_const(tmpglob);
13089 fname_len = strlen(fname);
13090 vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13091 if (vms_old_glob || (vms_dir != NULL)) {
13092 wilddsc.dsc$a_pointer = tovmspath_utf8(
13093 SvPVX(tmpglob),vmsspec,NULL);
13094 ok = (wilddsc.dsc$a_pointer != NULL);
13095 /* maybe passed 'foo' rather than '[.foo]', thus not
13099 /* Operate just on the directory, the special stat/fstat for */
13100 /* leaves the fileified specification in the st_devnam */
13102 wilddsc.dsc$a_pointer = st.st_devnam;
13107 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13108 ok = (wilddsc.dsc$a_pointer != NULL);
13111 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13113 /* If not extended character set, replace ? with % */
13114 /* With extended character set, ? is a wildcard single character */
13115 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13118 if (!decc_efs_charset)
13120 } else if (*cp == '%') {
13122 } else if (*cp == '*') {
13128 wv_sts = vms_split_path(
13129 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13130 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13131 &wvs_spec, &wvs_len);
13140 while (ok && $VMS_STATUS_SUCCESS(sts)) {
13141 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13142 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13146 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13147 &dfltdsc,NULL,&rms_sts,&lff_flags);
13148 if (!$VMS_STATUS_SUCCESS(sts))
13151 /* with varying string, 1st word of buffer contains result length */
13152 rstr[rslt->length] = '\0';
13154 /* Find where all the components are */
13155 v_sts = vms_split_path
13170 /* If no version on input, truncate the version on output */
13171 if (!hasver && (vs_len > 0)) {
13178 /* In Unix report mode, remove the ".dir;1" from the name */
13179 /* if it is a real directory */
13180 if (decc_filename_unix_report && decc_efs_charset) {
13181 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13185 ret_sts = flex_lstat(rstr, &statbuf);
13186 if ((ret_sts == 0) &&
13187 S_ISDIR(statbuf.st_mode)) {
13194 /* No version & a null extension on UNIX handling */
13195 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13201 if (!decc_efs_case_preserve) {
13202 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13205 /* Find File treats a Null extension as return all extensions */
13206 /* This is contrary to Perl expectations */
13208 if (wildstar || wildquery || vms_old_glob) {
13209 /* really need to see if the returned file name matched */
13210 /* but for now will assume that it matches */
13213 /* Exact Match requested */
13214 /* How are directories handled? - like a file */
13215 if ((e_len == we_len) && (n_len == wn_len)) {
13219 t1 = strncmp(e_spec, we_spec, e_len);
13223 t1 = strncmp(n_spec, we_spec, n_len);
13234 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13238 /* Start with the name */
13241 strcat(begin,"\n");
13242 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13245 if (cxt) (void)lib$find_file_end(&cxt);
13248 /* Be POSIXish: return the input pattern when no matches */
13249 my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13251 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13254 if (ok && sts != RMS$_NMF &&
13255 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13258 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13260 PerlIO_close(tmpfp);
13264 PerlIO_rewind(tmpfp);
13265 IoTYPE(io) = IoTYPE_RDONLY;
13266 IoIFP(io) = fp = tmpfp;
13267 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
13277 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13281 unixrealpath_fromperl(pTHX_ CV *cv)
13284 char *fspec, *rslt_spec, *rslt;
13287 if (!items || items != 1)
13288 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13290 fspec = SvPV(ST(0),n_a);
13291 if (!fspec || !*fspec) XSRETURN_UNDEF;
13293 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13294 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13296 ST(0) = sv_newmortal();
13298 sv_usepvn(ST(0),rslt,strlen(rslt));
13300 Safefree(rslt_spec);
13305 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13309 vmsrealpath_fromperl(pTHX_ CV *cv)
13312 char *fspec, *rslt_spec, *rslt;
13315 if (!items || items != 1)
13316 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13318 fspec = SvPV(ST(0),n_a);
13319 if (!fspec || !*fspec) XSRETURN_UNDEF;
13321 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13322 rslt = do_vms_realname(fspec, rslt_spec, NULL);
13324 ST(0) = sv_newmortal();
13326 sv_usepvn(ST(0),rslt,strlen(rslt));
13328 Safefree(rslt_spec);
13334 * A thin wrapper around decc$symlink to make sure we follow the
13335 * standard and do not create a symlink with a zero-length name,
13336 * and convert the target to Unix format, as the CRTL can't handle
13337 * targets in VMS format.
13339 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13341 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13346 if (!link_name || !*link_name) {
13347 SETERRNO(ENOENT, SS$_NOSUCHFILE);
13351 utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13352 /* An untranslatable filename should be passed through. */
13353 (void) int_tounixspec(contents, utarget, NULL);
13354 sts = symlink(utarget, link_name);
13355 PerlMem_free(utarget);
13360 #endif /* HAS_SYMLINK */
13362 int do_vms_case_tolerant(void);
13365 case_tolerant_process_fromperl(pTHX_ CV *cv)
13368 ST(0) = boolSV(do_vms_case_tolerant());
13372 #ifdef USE_ITHREADS
13375 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13376 struct interp_intern *dst)
13378 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13380 memcpy(dst,src,sizeof(struct interp_intern));
13386 Perl_sys_intern_clear(pTHX)
13391 Perl_sys_intern_init(pTHX)
13393 unsigned int ix = RAND_MAX;
13398 MY_POSIX_EXIT = vms_posix_exit;
13401 MY_INV_RAND_MAX = 1./x;
13405 init_os_extras(void)
13408 char* file = __FILE__;
13409 if (decc_disable_to_vms_logname_translation) {
13410 no_translate_barewords = TRUE;
13412 no_translate_barewords = FALSE;
13415 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13416 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13417 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13418 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13419 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13420 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13421 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13422 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13423 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13424 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13425 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13426 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13427 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13428 newXSproto("VMS::Filespec::case_tolerant_process",
13429 case_tolerant_process_fromperl,file,"");
13431 store_pipelocs(aTHX); /* will redo any earlier attempts */
13436 #if __CRTL_VER == 80200000
13437 /* This missed getting in to the DECC SDK for 8.2 */
13438 char *realpath(const char *file_name, char * resolved_name, ...);
13441 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13442 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13443 * The perl fallback routine to provide realpath() is not as efficient
13451 /* Hack, use old stat() as fastest way of getting ino_t and device */
13452 int decc$stat(const char *name, void * statbuf);
13453 #if __CRTL_VER >= 80200000
13454 int decc$lstat(const char *name, void * statbuf);
13456 #define decc$lstat decc$stat
13464 /* Realpath is fragile. In 8.3 it does not work if the feature
13465 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13466 * links are implemented in RMS, not the CRTL. It also can fail if the
13467 * user does not have read/execute access to some of the directories.
13468 * So in order for Do What I Mean mode to work, if realpath() fails,
13469 * fall back to looking up the filename by the device name and FID.
13472 int vms_fid_to_name(char * outname, int outlen,
13473 const char * name, int lstat_flag, mode_t * mode)
13475 #pragma message save
13476 #pragma message disable MISALGNDSTRCT
13477 #pragma message disable MISALGNDMEM
13478 #pragma member_alignment save
13479 #pragma nomember_alignment
13482 unsigned short st_ino[3];
13483 unsigned short old_st_mode;
13484 unsigned long padl[30]; /* plenty of room */
13486 #pragma message restore
13487 #pragma member_alignment restore
13490 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13491 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13496 /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13497 * unexpected answers
13500 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13501 if (fileified == NULL)
13502 _ckvmssts_noperl(SS$_INSFMEM);
13504 temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13505 if (temp_fspec == NULL)
13506 _ckvmssts_noperl(SS$_INSFMEM);
13509 /* First need to try as a directory */
13510 ret_spec = int_tovmspath(name, temp_fspec, NULL);
13511 if (ret_spec != NULL) {
13512 ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13513 if (ret_spec != NULL) {
13514 if (lstat_flag == 0)
13515 sts = decc$stat(fileified, &statbuf);
13517 sts = decc$lstat(fileified, &statbuf);
13521 /* Then as a VMS file spec */
13523 ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13524 if (ret_spec != NULL) {
13525 if (lstat_flag == 0) {
13526 sts = decc$stat(temp_fspec, &statbuf);
13528 sts = decc$lstat(temp_fspec, &statbuf);
13534 /* Next try - allow multiple dots with out EFS CHARSET */
13535 /* The CRTL stat() falls down hard on multi-dot filenames in unix
13536 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13537 * enable it if it isn't already.
13539 if (!decc_efs_charset && (decc_efs_charset_index > 0))
13540 decc$feature_set_value(decc_efs_charset_index, 1, 1);
13541 ret_spec = int_tovmspath(name, temp_fspec, NULL);
13542 if (lstat_flag == 0) {
13543 sts = decc$stat(name, &statbuf);
13545 sts = decc$lstat(name, &statbuf);
13547 if (!decc_efs_charset && (decc_efs_charset_index > 0))
13548 decc$feature_set_value(decc_efs_charset_index, 1, 0);
13552 /* and then because the Perl Unix to VMS conversion is not perfect */
13553 /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13554 /* characters from filenames so we need to try it as-is */
13556 if (lstat_flag == 0) {
13557 sts = decc$stat(name, &statbuf);
13559 sts = decc$lstat(name, &statbuf);
13566 dvidsc.dsc$a_pointer=statbuf.st_dev;
13567 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13569 specdsc.dsc$a_pointer = outname;
13570 specdsc.dsc$w_length = outlen-1;
13572 vms_sts = lib$fid_to_name
13573 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13574 if ($VMS_STATUS_SUCCESS(vms_sts)) {
13575 outname[specdsc.dsc$w_length] = 0;
13577 /* Return the mode */
13579 *mode = statbuf.old_st_mode;
13583 PerlMem_free(temp_fspec);
13584 PerlMem_free(fileified);
13591 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13594 char * rslt = NULL;
13597 if (decc_posix_compliant_pathnames > 0 ) {
13598 /* realpath currently only works if posix compliant pathnames are
13599 * enabled. It may start working when they are not, but in that
13600 * case we still want the fallback behavior for backwards compatibility
13602 rslt = realpath(filespec, outbuf);
13606 if (rslt == NULL) {
13608 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13609 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13612 /* Fall back to fid_to_name */
13614 Newx(vms_spec, VMS_MAXRSS + 1, char);
13616 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13620 /* Now need to trim the version off */
13621 sts = vms_split_path
13641 /* Trim off the version */
13642 int file_len = v_len + r_len + d_len + n_len + e_len;
13643 vms_spec[file_len] = 0;
13645 /* Trim off the .DIR if this is a directory */
13646 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13647 if (S_ISDIR(my_mode)) {
13653 /* Drop NULL extensions on UNIX file specification */
13654 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13659 /* The result is expected to be in UNIX format */
13660 rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13662 /* Downcase if input had any lower case letters and
13663 * case preservation is not in effect.
13665 if (!decc_efs_case_preserve) {
13666 for (cp = filespec; *cp; cp++)
13667 if (islower(*cp)) { haslower = 1; break; }
13669 if (haslower) __mystrtolower(rslt);
13674 /* Now for some hacks to deal with backwards and forward */
13675 /* compatibility */
13676 if (!decc_efs_charset) {
13678 /* 1. ODS-2 mode wants to do a syntax only translation */
13679 rslt = int_rmsexpand(filespec, outbuf,
13680 NULL, 0, NULL, utf8_fl);
13683 if (decc_filename_unix_report) {
13685 char * vms_dir_name;
13688 /* 2. ODS-5 / UNIX report mode should return a failure */
13689 /* if the parent directory also does not exist */
13690 /* Otherwise, get the real path for the parent */
13691 /* and add the child to it. */
13693 /* basename / dirname only available for VMS 7.0+ */
13694 /* So we may need to implement them as common routines */
13696 Newx(dir_name, VMS_MAXRSS + 1, char);
13697 Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13698 dir_name[0] = '\0';
13701 /* First try a VMS parse */
13702 sts = vms_split_path
13720 int dir_len = v_len + r_len + d_len + n_len;
13722 memcpy(dir_name, filespec, dir_len);
13723 dir_name[dir_len] = '\0';
13724 file_name = (char *)&filespec[dir_len + 1];
13727 /* This must be UNIX */
13730 tchar = strrchr(filespec, '/');
13732 if (tchar != NULL) {
13733 int dir_len = tchar - filespec;
13734 memcpy(dir_name, filespec, dir_len);
13735 dir_name[dir_len] = '\0';
13736 file_name = (char *) &filespec[dir_len + 1];
13740 /* Dir name is defaulted */
13741 if (dir_name[0] == 0) {
13743 dir_name[1] = '\0';
13746 /* Need realpath for the directory */
13747 sts = vms_fid_to_name(vms_dir_name,
13749 dir_name, 0, NULL);
13752 /* Now need to pathify it. */
13753 char *tdir = int_pathify_dirspec(vms_dir_name,
13756 /* And now add the original filespec to it */
13757 if (file_name != NULL) {
13758 my_strlcat(outbuf, file_name, VMS_MAXRSS);
13762 Safefree(vms_dir_name);
13763 Safefree(dir_name);
13767 Safefree(vms_spec);
13773 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13776 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13777 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13779 /* Fall back to fid_to_name */
13781 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13788 /* Now need to trim the version off */
13789 sts = vms_split_path
13809 /* Trim off the version */
13810 int file_len = v_len + r_len + d_len + n_len + e_len;
13811 outbuf[file_len] = 0;
13813 /* Downcase if input had any lower case letters and
13814 * case preservation is not in effect.
13816 if (!decc_efs_case_preserve) {
13817 for (cp = filespec; *cp; cp++)
13818 if (islower(*cp)) { haslower = 1; break; }
13820 if (haslower) __mystrtolower(outbuf);
13829 /* External entry points */
13831 Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13833 return do_vms_realpath(filespec, outbuf, utf8_fl);
13837 Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13839 return do_vms_realname(filespec, outbuf, utf8_fl);
13842 /* case_tolerant */
13844 /*{{{int do_vms_case_tolerant(void)*/
13845 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13846 * controlled by a process setting.
13849 do_vms_case_tolerant(void)
13851 return vms_process_case_tolerant;
13854 /* External entry points */
13856 Perl_vms_case_tolerant(void)
13858 return do_vms_case_tolerant();
13861 /* Start of DECC RTL Feature handling */
13864 set_feature_default(const char *name, int value)
13870 /* If the feature has been explicitly disabled in the environment,
13871 * then don't enable it here.
13874 status = simple_trnlnm(name, val_str, sizeof(val_str));
13876 val_str[0] = _toupper(val_str[0]);
13877 if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
13882 index = decc$feature_get_index(name);
13884 status = decc$feature_set_value(index, 1, value);
13885 if (index == -1 || (status == -1)) {
13889 status = decc$feature_get_value(index, 1);
13890 if (status != value) {
13894 /* Various things may check for an environment setting
13895 * rather than the feature directly, so set that too.
13897 vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13903 /* C RTL Feature settings */
13905 #if defined(__DECC) || defined(__DECCXX)
13912 vmsperl_set_features(void)
13917 #if defined(JPI$_CASE_LOOKUP_PERM)
13918 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13919 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13920 unsigned long case_perm;
13921 unsigned long case_image;
13924 /* Allow an exception to bring Perl into the VMS debugger */
13925 vms_debug_on_exception = 0;
13926 status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13928 val_str[0] = _toupper(val_str[0]);
13929 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13930 vms_debug_on_exception = 1;
13932 vms_debug_on_exception = 0;
13935 /* Debug unix/vms file translation routines */
13936 vms_debug_fileify = 0;
13937 status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13939 val_str[0] = _toupper(val_str[0]);
13940 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13941 vms_debug_fileify = 1;
13943 vms_debug_fileify = 0;
13947 /* Historically PERL has been doing vmsify / stat differently than */
13948 /* the CRTL. In particular, under some conditions the CRTL will */
13949 /* remove some illegal characters like spaces from filenames */
13950 /* resulting in some differences. The stat()/lstat() wrapper has */
13951 /* been reporting such file names as invalid and fails to stat them */
13952 /* fixing this bug so that stat()/lstat() accept these like the */
13953 /* CRTL does will result in several tests failing. */
13954 /* This should really be fixed, but for now, set up a feature to */
13955 /* enable it so that the impact can be studied. */
13956 vms_bug_stat_filename = 0;
13957 status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13959 val_str[0] = _toupper(val_str[0]);
13960 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13961 vms_bug_stat_filename = 1;
13963 vms_bug_stat_filename = 0;
13967 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13968 vms_vtf7_filenames = 0;
13969 status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13971 val_str[0] = _toupper(val_str[0]);
13972 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13973 vms_vtf7_filenames = 1;
13975 vms_vtf7_filenames = 0;
13978 /* unlink all versions on unlink() or rename() */
13979 vms_unlink_all_versions = 0;
13980 status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13982 val_str[0] = _toupper(val_str[0]);
13983 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13984 vms_unlink_all_versions = 1;
13986 vms_unlink_all_versions = 0;
13989 /* Detect running under GNV Bash or other UNIX like shell */
13990 gnv_unix_shell = 0;
13991 status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13993 gnv_unix_shell = 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;
14000 /* Reverse default ordering of PERL_ENV_TABLES. */
14001 defenv[0] = &crtlenvdsc;
14002 defenv[1] = &fildevdsc;
14004 /* Some reasonable defaults that are not CRTL defaults */
14005 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14006 set_feature_default("DECC$ARGV_PARSE_STYLE", 1); /* Requires extended parse. */
14007 set_feature_default("DECC$EFS_CHARSET", 1);
14009 /* hacks to see if known bugs are still present for testing */
14011 /* PCP mode requires creating /dev/null special device file */
14012 decc_bug_devnull = 0;
14013 status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14015 val_str[0] = _toupper(val_str[0]);
14016 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14017 decc_bug_devnull = 1;
14019 decc_bug_devnull = 0;
14022 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14024 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14025 if (decc_disable_to_vms_logname_translation < 0)
14026 decc_disable_to_vms_logname_translation = 0;
14029 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14031 decc_efs_case_preserve = decc$feature_get_value(s, 1);
14032 if (decc_efs_case_preserve < 0)
14033 decc_efs_case_preserve = 0;
14036 s = decc$feature_get_index("DECC$EFS_CHARSET");
14037 decc_efs_charset_index = s;
14039 decc_efs_charset = decc$feature_get_value(s, 1);
14040 if (decc_efs_charset < 0)
14041 decc_efs_charset = 0;
14044 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14046 decc_filename_unix_report = decc$feature_get_value(s, 1);
14047 if (decc_filename_unix_report > 0) {
14048 decc_filename_unix_report = 1;
14049 vms_posix_exit = 1;
14052 decc_filename_unix_report = 0;
14055 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14057 decc_filename_unix_only = decc$feature_get_value(s, 1);
14058 if (decc_filename_unix_only > 0) {
14059 decc_filename_unix_only = 1;
14062 decc_filename_unix_only = 0;
14066 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14068 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14069 if (decc_filename_unix_no_version < 0)
14070 decc_filename_unix_no_version = 0;
14073 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14075 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14076 if (decc_readdir_dropdotnotype < 0)
14077 decc_readdir_dropdotnotype = 0;
14080 #if __CRTL_VER >= 80200000
14081 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14083 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14084 if (decc_posix_compliant_pathnames < 0)
14085 decc_posix_compliant_pathnames = 0;
14086 if (decc_posix_compliant_pathnames > 4)
14087 decc_posix_compliant_pathnames = 0;
14092 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND)
14094 /* Report true case tolerance */
14095 /*----------------------------*/
14096 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14097 if (!$VMS_STATUS_SUCCESS(status))
14098 case_perm = PPROP$K_CASE_BLIND;
14099 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14100 if (!$VMS_STATUS_SUCCESS(status))
14101 case_image = PPROP$K_CASE_BLIND;
14102 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14103 (case_image == PPROP$K_CASE_SENSITIVE))
14104 vms_process_case_tolerant = 0;
14108 /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
14109 /* for strict backward compatibility */
14110 status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14112 val_str[0] = _toupper(val_str[0]);
14113 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14114 vms_posix_exit = 1;
14116 vms_posix_exit = 0;
14120 /* Use 32-bit pointers because that's what the image activator
14121 * assumes for the LIB$INITIALZE psect.
14123 #if __INITIAL_POINTER_SIZE
14124 #pragma pointer_size save
14125 #pragma pointer_size 32
14128 /* Create a reference to the LIB$INITIALIZE function. */
14129 extern void LIB$INITIALIZE(void);
14130 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14132 /* Create an array of pointers to the init functions in the special
14133 * LIB$INITIALIZE section. In our case, the array only has one entry.
14135 #pragma extern_model save
14136 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
14137 extern void (* const vmsperl_unused_global_2[])() =
14139 vmsperl_set_features,
14141 #pragma extern_model restore
14143 #if __INITIAL_POINTER_SIZE
14144 #pragma pointer_size restore
14151 #endif /* defined(__DECC) || defined(__DECCXX) */