3 * VMS-specific routines for perl5
5 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
6 * 2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
8 * You may distribute under the terms of either the GNU General Public
9 * License or the Artistic License, as specified in the README file.
11 * Please see Changes*.* or the Perl Repository Browser for revision history.
20 #include <climsgdef.h>
31 #include <libclidef.h>
33 #include <lib$routines.h>
37 #if __CRTL_VER >= 70301000 && !defined(__VAX)
47 #include <str$routines.h>
54 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
56 #define NO_EFN EFN$C_ENF
61 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
62 int decc$feature_get_index(const char *name);
63 char* decc$feature_get_name(int index);
64 int decc$feature_get_value(int index, int mode);
65 int decc$feature_set_value(int index, int mode, int value);
70 #pragma member_alignment save
71 #pragma nomember_alignment longword
76 unsigned short * retadr;
78 #pragma member_alignment restore
80 /* More specific prototype than in starlet_c.h makes programming errors
88 const struct dsc$descriptor_s * devnam,
89 const struct item_list_3 * itmlst,
91 void * (astadr)(unsigned long),
96 #ifdef sys$get_security
97 #undef sys$get_security
99 (const struct dsc$descriptor_s * clsnam,
100 const struct dsc$descriptor_s * objnam,
101 const unsigned int *objhan,
103 const struct item_list_3 * itmlst,
104 unsigned int * contxt,
105 const unsigned int * acmode);
108 #ifdef sys$set_security
109 #undef sys$set_security
111 (const struct dsc$descriptor_s * clsnam,
112 const struct dsc$descriptor_s * objnam,
113 const unsigned int *objhan,
115 const struct item_list_3 * itmlst,
116 unsigned int * contxt,
117 const unsigned int * acmode);
120 #ifdef lib$find_image_symbol
121 #undef lib$find_image_symbol
122 int lib$find_image_symbol
123 (const struct dsc$descriptor_s * imgname,
124 const struct dsc$descriptor_s * symname,
126 const struct dsc$descriptor_s * defspec,
130 #ifdef lib$rename_file
131 #undef lib$rename_file
133 (const struct dsc$descriptor_s * old_file_dsc,
134 const struct dsc$descriptor_s * new_file_dsc,
135 const struct dsc$descriptor_s * default_file_dsc,
136 const struct dsc$descriptor_s * related_file_dsc,
137 const unsigned long * flags,
138 void * (success)(const struct dsc$descriptor_s * old_dsc,
139 const struct dsc$descriptor_s * new_dsc,
141 void * (error)(const struct dsc$descriptor_s * old_dsc,
142 const struct dsc$descriptor_s * new_dsc,
145 const int * error_src,
146 const void * usr_arg),
147 int (confirm)(const struct dsc$descriptor_s * old_dsc,
148 const struct dsc$descriptor_s * new_dsc,
149 const void * old_fab,
150 const void * usr_arg),
152 struct dsc$descriptor_s * old_result_name_dsc,
153 struct dsc$descriptor_s * new_result_name_dsc,
154 unsigned long * file_scan_context);
157 #if __CRTL_VER >= 70300000 && !defined(__VAX)
159 static int set_feature_default(const char *name, int value)
164 index = decc$feature_get_index(name);
166 status = decc$feature_set_value(index, 1, value);
167 if (index == -1 || (status == -1)) {
171 status = decc$feature_get_value(index, 1);
172 if (status != value) {
180 /* Older versions of ssdef.h don't have these */
181 #ifndef SS$_INVFILFOROP
182 # define SS$_INVFILFOROP 3930
184 #ifndef SS$_NOSUCHOBJECT
185 # define SS$_NOSUCHOBJECT 2696
188 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
189 #define PERLIO_NOT_STDIO 0
191 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
192 * code below needs to get to the underlying CRTL routines. */
193 #define DONT_MASK_RTL_CALLS
197 /* Anticipating future expansion in lexical warnings . . . */
198 #ifndef WARN_INTERNAL
199 # define WARN_INTERNAL WARN_MISC
202 #ifdef VMS_LONGNAME_SUPPORT
203 #include <libfildef.h>
206 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
207 # define RTL_USES_UTC 1
210 /* Routine to create a decterm for use with the Perl debugger */
211 /* No headers, this information was found in the Programming Concepts Manual */
213 static int (*decw_term_port)
214 (const struct dsc$descriptor_s * display,
215 const struct dsc$descriptor_s * setup_file,
216 const struct dsc$descriptor_s * customization,
217 struct dsc$descriptor_s * result_device_name,
218 unsigned short * result_device_name_length,
221 void * char_change_buffer) = 0;
223 /* gcc's header files don't #define direct access macros
224 * corresponding to VAXC's variant structs */
226 # define uic$v_format uic$r_uic_form.uic$v_format
227 # define uic$v_group uic$r_uic_form.uic$v_group
228 # define uic$v_member uic$r_uic_form.uic$v_member
229 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
230 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
231 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
232 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
235 #if defined(NEED_AN_H_ERRNO)
240 #pragma message disable pragma
241 #pragma member_alignment save
242 #pragma nomember_alignment longword
244 #pragma message disable misalgndmem
247 unsigned short int buflen;
248 unsigned short int itmcode;
250 unsigned short int *retlen;
253 struct filescan_itmlst_2 {
254 unsigned short length;
255 unsigned short itmcode;
260 unsigned short length;
265 #pragma message restore
266 #pragma member_alignment restore
269 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
270 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
271 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
272 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
273 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
274 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
275 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
276 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
277 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
278 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
279 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
281 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
282 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
283 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
284 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
286 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
287 #define PERL_LNM_MAX_ALLOWED_INDEX 127
289 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
290 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
293 #define PERL_LNM_MAX_ITER 10
295 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
296 #if __CRTL_VER >= 70302000 && !defined(__VAX)
297 #define MAX_DCL_SYMBOL (8192)
298 #define MAX_DCL_LINE_LENGTH (4096 - 4)
300 #define MAX_DCL_SYMBOL (1024)
301 #define MAX_DCL_LINE_LENGTH (1024 - 4)
304 static char *__mystrtolower(char *str)
306 if (str) for (; *str; ++str) *str= tolower(*str);
310 static struct dsc$descriptor_s fildevdsc =
311 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
312 static struct dsc$descriptor_s crtlenvdsc =
313 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
314 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
315 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
316 static struct dsc$descriptor_s **env_tables = defenv;
317 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
319 /* True if we shouldn't treat barewords as logicals during directory */
321 static int no_translate_barewords;
324 static int tz_updated = 1;
327 /* DECC Features that may need to affect how Perl interprets
328 * displays filename information
330 static int decc_disable_to_vms_logname_translation = 1;
331 static int decc_disable_posix_root = 1;
332 int decc_efs_case_preserve = 0;
333 static int decc_efs_charset = 0;
334 static int decc_filename_unix_no_version = 0;
335 static int decc_filename_unix_only = 0;
336 int decc_filename_unix_report = 0;
337 int decc_posix_compliant_pathnames = 0;
338 int decc_readdir_dropdotnotype = 0;
339 static int vms_process_case_tolerant = 1;
340 int vms_vtf7_filenames = 0;
341 int gnv_unix_shell = 0;
342 static int vms_unlink_all_versions = 0;
344 /* bug workarounds if needed */
345 int decc_bug_readdir_efs1 = 0;
346 int decc_bug_devnull = 1;
347 int decc_bug_fgetname = 0;
348 int decc_dir_barename = 0;
350 static int vms_debug_on_exception = 0;
352 /* Is this a UNIX file specification?
353 * No longer a simple check with EFS file specs
354 * For now, not a full check, but need to
355 * handle POSIX ^UP^ specifications
356 * Fixing to handle ^/ cases would require
357 * changes to many other conversion routines.
360 static int is_unix_filespec(const char *path)
366 if (strncmp(path,"\"^UP^",5) != 0) {
367 pch1 = strchr(path, '/');
372 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
373 if (decc_filename_unix_report || decc_filename_unix_only) {
374 if (strcmp(path,".") == 0)
382 /* This routine converts a UCS-2 character to be VTF-7 encoded.
385 static void ucs2_to_vtf7
387 unsigned long ucs2_char,
390 unsigned char * ucs_ptr;
393 ucs_ptr = (unsigned char *)&ucs2_char;
397 hex = (ucs_ptr[1] >> 4) & 0xf;
399 outspec[2] = hex + '0';
401 outspec[2] = (hex - 9) + 'A';
402 hex = ucs_ptr[1] & 0xF;
404 outspec[3] = hex + '0';
406 outspec[3] = (hex - 9) + 'A';
408 hex = (ucs_ptr[0] >> 4) & 0xf;
410 outspec[4] = hex + '0';
412 outspec[4] = (hex - 9) + 'A';
413 hex = ucs_ptr[1] & 0xF;
415 outspec[5] = hex + '0';
417 outspec[5] = (hex - 9) + 'A';
423 /* This handles the conversion of a UNIX extended character set to a ^
424 * escaped VMS character.
425 * in a UNIX file specification.
427 * The output count variable contains the number of characters added
428 * to the output string.
430 * The return value is the number of characters read from the input string
432 static int copy_expand_unix_filename_escape
433 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
441 utf8_flag = *utf8_fl;
445 if (*inspec >= 0x80) {
446 if (utf8_fl && vms_vtf7_filenames) {
447 unsigned long ucs_char;
451 if ((*inspec & 0xE0) == 0xC0) {
453 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
454 if (ucs_char >= 0x80) {
455 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
458 } else if ((*inspec & 0xF0) == 0xE0) {
460 ucs_char = ((inspec[0] & 0xF) << 12) +
461 ((inspec[1] & 0x3f) << 6) +
463 if (ucs_char >= 0x800) {
464 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
468 #if 0 /* I do not see longer sequences supported by OpenVMS */
469 /* Maybe some one can fix this later */
470 } else if ((*inspec & 0xF8) == 0xF0) {
473 } else if ((*inspec & 0xFC) == 0xF8) {
476 } else if ((*inspec & 0xFE) == 0xFC) {
483 /* High bit set, but not a Unicode character! */
485 /* Non printing DECMCS or ISO Latin-1 character? */
486 if (*inspec <= 0x9F) {
490 hex = (*inspec >> 4) & 0xF;
492 outspec[1] = hex + '0';
494 outspec[1] = (hex - 9) + 'A';
498 outspec[2] = hex + '0';
500 outspec[2] = (hex - 9) + 'A';
504 } else if (*inspec == 0xA0) {
510 } else if (*inspec == 0xFF) {
522 /* Is this a macro that needs to be passed through?
523 * Macros start with $( and an alpha character, followed
524 * by a string of alpha numeric characters ending with a )
525 * If this does not match, then encode it as ODS-5.
527 if ((inspec[0] == '$') && (inspec[1] == '(')) {
530 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
532 outspec[0] = inspec[0];
533 outspec[1] = inspec[1];
534 outspec[2] = inspec[2];
536 while(isalnum(inspec[tcnt]) ||
537 (inspec[2] == '.') || (inspec[2] == '_')) {
538 outspec[tcnt] = inspec[tcnt];
541 if (inspec[tcnt] == ')') {
542 outspec[tcnt] = inspec[tcnt];
559 if (decc_efs_charset == 0)
585 /* Don't escape again if following character is
586 * already something we escape.
588 if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
594 /* But otherwise fall through and escape it. */
596 /* Assume that this is to be escaped */
598 outspec[1] = *inspec;
602 case ' ': /* space */
603 /* Assume that this is to be escaped */
618 /* This handles the expansion of a '^' prefix to the proper character
619 * in a UNIX file specification.
621 * The output count variable contains the number of characters added
622 * to the output string.
624 * The return value is the number of characters read from the input
627 static int copy_expand_vms_filename_escape
628 (char *outspec, const char *inspec, int *output_cnt)
635 if (*inspec == '^') {
638 /* Spaces and non-trailing dots should just be passed through,
639 * but eat the escape character.
646 case '_': /* space */
652 /* Hmm. Better leave the escape escaped. */
658 case 'U': /* Unicode - FIX-ME this is wrong. */
661 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
664 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
665 outspec[0] == c1 & 0xff;
666 outspec[1] == c2 & 0xff;
673 /* Error - do best we can to continue */
683 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
687 scnt = sscanf(inspec, "%2x", &c1);
688 outspec[0] = c1 & 0xff;
712 (const struct dsc$descriptor_s * srcstr,
713 struct filescan_itmlst_2 * valuelist,
714 unsigned long * fldflags,
715 struct dsc$descriptor_s *auxout,
716 unsigned short * retlen);
719 /* vms_split_path - Verify that the input file specification is a
720 * VMS format file specification, and provide pointers to the components of
721 * it. With EFS format filenames, this is virtually the only way to
722 * parse a VMS path specification into components.
724 * If the sum of the components do not add up to the length of the
725 * string, then the passed file specification is probably a UNIX style
728 static int vms_split_path
743 struct dsc$descriptor path_desc;
747 struct filescan_itmlst_2 item_list[9];
748 const int filespec = 0;
749 const int nodespec = 1;
750 const int devspec = 2;
751 const int rootspec = 3;
752 const int dirspec = 4;
753 const int namespec = 5;
754 const int typespec = 6;
755 const int verspec = 7;
757 /* Assume the worst for an easy exit */
772 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
773 path_desc.dsc$w_length = strlen(path);
774 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
775 path_desc.dsc$b_class = DSC$K_CLASS_S;
777 /* Get the total length, if it is shorter than the string passed
778 * then this was probably not a VMS formatted file specification
780 item_list[filespec].itmcode = FSCN$_FILESPEC;
781 item_list[filespec].length = 0;
782 item_list[filespec].component = NULL;
784 /* If the node is present, then it gets considered as part of the
785 * volume name to hopefully make things simple.
787 item_list[nodespec].itmcode = FSCN$_NODE;
788 item_list[nodespec].length = 0;
789 item_list[nodespec].component = NULL;
791 item_list[devspec].itmcode = FSCN$_DEVICE;
792 item_list[devspec].length = 0;
793 item_list[devspec].component = NULL;
795 /* root is a special case, adding it to either the directory or
796 * the device components will probalby complicate things for the
797 * callers of this routine, so leave it separate.
799 item_list[rootspec].itmcode = FSCN$_ROOT;
800 item_list[rootspec].length = 0;
801 item_list[rootspec].component = NULL;
803 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
804 item_list[dirspec].length = 0;
805 item_list[dirspec].component = NULL;
807 item_list[namespec].itmcode = FSCN$_NAME;
808 item_list[namespec].length = 0;
809 item_list[namespec].component = NULL;
811 item_list[typespec].itmcode = FSCN$_TYPE;
812 item_list[typespec].length = 0;
813 item_list[typespec].component = NULL;
815 item_list[verspec].itmcode = FSCN$_VERSION;
816 item_list[verspec].length = 0;
817 item_list[verspec].component = NULL;
819 item_list[8].itmcode = 0;
820 item_list[8].length = 0;
821 item_list[8].component = NULL;
823 status = sys$filescan
824 ((const struct dsc$descriptor_s *)&path_desc, item_list,
826 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
828 /* If we parsed it successfully these two lengths should be the same */
829 if (path_desc.dsc$w_length != item_list[filespec].length)
832 /* If we got here, then it is a VMS file specification */
835 /* set the volume name */
836 if (item_list[nodespec].length > 0) {
837 *volume = item_list[nodespec].component;
838 *vol_len = item_list[nodespec].length + item_list[devspec].length;
841 *volume = item_list[devspec].component;
842 *vol_len = item_list[devspec].length;
845 *root = item_list[rootspec].component;
846 *root_len = item_list[rootspec].length;
848 *dir = item_list[dirspec].component;
849 *dir_len = item_list[dirspec].length;
851 /* Now fun with versions and EFS file specifications
852 * The parser can not tell the difference when a "." is a version
853 * delimiter or a part of the file specification.
855 if ((decc_efs_charset) &&
856 (item_list[verspec].length > 0) &&
857 (item_list[verspec].component[0] == '.')) {
858 *name = item_list[namespec].component;
859 *name_len = item_list[namespec].length + item_list[typespec].length;
860 *ext = item_list[verspec].component;
861 *ext_len = item_list[verspec].length;
866 *name = item_list[namespec].component;
867 *name_len = item_list[namespec].length;
868 *ext = item_list[typespec].component;
869 *ext_len = item_list[typespec].length;
870 *version = item_list[verspec].component;
871 *ver_len = item_list[verspec].length;
878 * Routine to retrieve the maximum equivalence index for an input
879 * logical name. Some calls to this routine have no knowledge if
880 * the variable is a logical or not. So on error we return a max
883 /*{{{int my_maxidx(const char *lnm) */
885 my_maxidx(const char *lnm)
889 int attr = LNM$M_CASE_BLIND;
890 struct dsc$descriptor lnmdsc;
891 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
894 lnmdsc.dsc$w_length = strlen(lnm);
895 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
896 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
897 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
899 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
900 if ((status & 1) == 0)
907 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
909 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
910 struct dsc$descriptor_s **tabvec, unsigned long int flags)
913 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
914 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
915 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
917 unsigned char acmode;
918 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
919 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
920 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
921 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
923 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
924 #if defined(PERL_IMPLICIT_CONTEXT)
927 aTHX = PERL_GET_INTERP;
933 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
934 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
936 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
937 *cp2 = _toupper(*cp1);
938 if (cp1 - lnm > LNM$C_NAMLENGTH) {
939 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
943 lnmdsc.dsc$w_length = cp1 - lnm;
944 lnmdsc.dsc$a_pointer = uplnm;
945 uplnm[lnmdsc.dsc$w_length] = '\0';
946 secure = flags & PERL__TRNENV_SECURE;
947 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
948 if (!tabvec || !*tabvec) tabvec = env_tables;
950 for (curtab = 0; tabvec[curtab]; curtab++) {
951 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
952 if (!ivenv && !secure) {
957 Perl_warn(aTHX_ "Can't read CRTL environ\n");
960 retsts = SS$_NOLOGNAM;
961 for (i = 0; environ[i]; i++) {
962 if ((eq = strchr(environ[i],'=')) &&
963 lnmdsc.dsc$w_length == (eq - environ[i]) &&
964 !strncmp(environ[i],uplnm,eq - environ[i])) {
966 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
967 if (!eqvlen) continue;
972 if (retsts != SS$_NOLOGNAM) break;
975 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
976 !str$case_blind_compare(&tmpdsc,&clisym)) {
977 if (!ivsym && !secure) {
978 unsigned short int deflen = LNM$C_NAMLENGTH;
979 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
980 /* dynamic dsc to accomodate possible long value */
981 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
982 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
984 if (eqvlen > MAX_DCL_SYMBOL) {
985 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
986 eqvlen = MAX_DCL_SYMBOL;
987 /* Special hack--we might be called before the interpreter's */
988 /* fully initialized, in which case either thr or PL_curcop */
989 /* might be bogus. We have to check, since ckWARN needs them */
990 /* both to be valid if running threaded */
991 if (ckWARN(WARN_MISC)) {
992 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
995 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
997 _ckvmssts(lib$sfree1_dd(&eqvdsc));
998 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
999 if (retsts == LIB$_NOSUCHSYM) continue;
1004 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1005 midx = my_maxidx(lnm);
1006 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1007 lnmlst[1].bufadr = cp2;
1009 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1010 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1011 if (retsts == SS$_NOLOGNAM) break;
1012 /* PPFs have a prefix */
1015 *((int *)uplnm) == *((int *)"SYS$") &&
1017 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1018 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1019 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1020 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1021 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
1022 memmove(eqv,eqv+4,eqvlen-4);
1028 if ((retsts == SS$_IVLOGNAM) ||
1029 (retsts == SS$_NOLOGNAM)) { continue; }
1032 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1033 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1034 if (retsts == SS$_NOLOGNAM) continue;
1037 eqvlen = strlen(eqv);
1041 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1042 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1043 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1044 retsts == SS$_NOLOGNAM) {
1045 set_errno(EINVAL); set_vaxc_errno(retsts);
1047 else _ckvmssts(retsts);
1049 } /* end of vmstrnenv */
1052 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1053 /* Define as a function so we can access statics. */
1054 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1056 return vmstrnenv(lnm,eqv,idx,fildev,
1057 #ifdef SECURE_INTERNAL_GETENV
1058 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1067 * Note: Uses Perl temp to store result so char * can be returned to
1068 * caller; this pointer will be invalidated at next Perl statement
1070 * We define this as a function rather than a macro in terms of my_getenv_len()
1071 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1074 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1076 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1079 static char *__my_getenv_eqv = NULL;
1080 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1081 unsigned long int idx = 0;
1082 int trnsuccess, success, secure, saverr, savvmserr;
1086 midx = my_maxidx(lnm) + 1;
1088 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1089 /* Set up a temporary buffer for the return value; Perl will
1090 * clean it up at the next statement transition */
1091 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1092 if (!tmpsv) return NULL;
1096 /* Assume no interpreter ==> single thread */
1097 if (__my_getenv_eqv != NULL) {
1098 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1101 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1103 eqv = __my_getenv_eqv;
1106 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1107 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1109 getcwd(eqv,LNM$C_NAMLENGTH);
1113 /* Get rid of "000000/ in rooted filespecs */
1116 zeros = strstr(eqv, "/000000/");
1117 if (zeros != NULL) {
1119 mlen = len - (zeros - eqv) - 7;
1120 memmove(zeros, &zeros[7], mlen);
1128 /* Impose security constraints only if tainting */
1130 /* Impose security constraints only if tainting */
1131 secure = PL_curinterp ? PL_tainting : will_taint;
1132 saverr = errno; savvmserr = vaxc$errno;
1139 #ifdef SECURE_INTERNAL_GETENV
1140 secure ? PERL__TRNENV_SECURE : 0
1146 /* For the getenv interface we combine all the equivalence names
1147 * of a search list logical into one value to acquire a maximum
1148 * value length of 255*128 (assuming %ENV is using logicals).
1150 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1152 /* If the name contains a semicolon-delimited index, parse it
1153 * off and make sure we only retrieve the equivalence name for
1155 if ((cp2 = strchr(lnm,';')) != NULL) {
1157 uplnm[cp2-lnm] = '\0';
1158 idx = strtoul(cp2+1,NULL,0);
1160 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1163 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1165 /* Discard NOLOGNAM on internal calls since we're often looking
1166 * for an optional name, and this "error" often shows up as the
1167 * (bogus) exit status for a die() call later on. */
1168 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1169 return success ? eqv : Nullch;
1172 } /* end of my_getenv() */
1176 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1178 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1182 unsigned long idx = 0;
1184 static char *__my_getenv_len_eqv = NULL;
1185 int secure, saverr, savvmserr;
1188 midx = my_maxidx(lnm) + 1;
1190 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1191 /* Set up a temporary buffer for the return value; Perl will
1192 * clean it up at the next statement transition */
1193 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1194 if (!tmpsv) return NULL;
1198 /* Assume no interpreter ==> single thread */
1199 if (__my_getenv_len_eqv != NULL) {
1200 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1203 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1205 buf = __my_getenv_len_eqv;
1208 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1209 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1212 getcwd(buf,LNM$C_NAMLENGTH);
1215 /* Get rid of "000000/ in rooted filespecs */
1217 zeros = strstr(buf, "/000000/");
1218 if (zeros != NULL) {
1220 mlen = *len - (zeros - buf) - 7;
1221 memmove(zeros, &zeros[7], mlen);
1230 /* Impose security constraints only if tainting */
1231 secure = PL_curinterp ? PL_tainting : will_taint;
1232 saverr = errno; savvmserr = vaxc$errno;
1239 #ifdef SECURE_INTERNAL_GETENV
1240 secure ? PERL__TRNENV_SECURE : 0
1246 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1248 if ((cp2 = strchr(lnm,';')) != NULL) {
1250 buf[cp2-lnm] = '\0';
1251 idx = strtoul(cp2+1,NULL,0);
1253 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1256 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1258 /* Get rid of "000000/ in rooted filespecs */
1261 zeros = strstr(buf, "/000000/");
1262 if (zeros != NULL) {
1264 mlen = *len - (zeros - buf) - 7;
1265 memmove(zeros, &zeros[7], mlen);
1271 /* Discard NOLOGNAM on internal calls since we're often looking
1272 * for an optional name, and this "error" often shows up as the
1273 * (bogus) exit status for a die() call later on. */
1274 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1275 return *len ? buf : Nullch;
1278 } /* end of my_getenv_len() */
1281 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1283 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1285 /*{{{ void prime_env_iter() */
1287 prime_env_iter(void)
1288 /* Fill the %ENV associative array with all logical names we can
1289 * find, in preparation for iterating over it.
1292 static int primed = 0;
1293 HV *seenhv = NULL, *envhv;
1295 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1296 unsigned short int chan;
1297 #ifndef CLI$M_TRUSTED
1298 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1300 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1301 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1303 bool have_sym = FALSE, have_lnm = FALSE;
1304 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1305 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1306 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1307 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1308 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1309 #if defined(PERL_IMPLICIT_CONTEXT)
1312 #if defined(USE_ITHREADS)
1313 static perl_mutex primenv_mutex;
1314 MUTEX_INIT(&primenv_mutex);
1317 #if defined(PERL_IMPLICIT_CONTEXT)
1318 /* We jump through these hoops because we can be called at */
1319 /* platform-specific initialization time, which is before anything is */
1320 /* set up--we can't even do a plain dTHX since that relies on the */
1321 /* interpreter structure to be initialized */
1323 aTHX = PERL_GET_INTERP;
1329 if (primed || !PL_envgv) return;
1330 MUTEX_LOCK(&primenv_mutex);
1331 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1332 envhv = GvHVn(PL_envgv);
1333 /* Perform a dummy fetch as an lval to insure that the hash table is
1334 * set up. Otherwise, the hv_store() will turn into a nullop. */
1335 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1337 for (i = 0; env_tables[i]; i++) {
1338 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1339 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1340 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1342 if (have_sym || have_lnm) {
1343 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1344 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1345 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1346 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1349 for (i--; i >= 0; i--) {
1350 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1353 for (j = 0; environ[j]; j++) {
1354 if (!(start = strchr(environ[j],'='))) {
1355 if (ckWARN(WARN_INTERNAL))
1356 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1360 sv = newSVpv(start,0);
1362 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1367 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1368 !str$case_blind_compare(&tmpdsc,&clisym)) {
1369 strcpy(cmd,"Show Symbol/Global *");
1370 cmddsc.dsc$w_length = 20;
1371 if (env_tables[i]->dsc$w_length == 12 &&
1372 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1373 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1374 flags = defflags | CLI$M_NOLOGNAM;
1377 strcpy(cmd,"Show Logical *");
1378 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1379 strcat(cmd," /Table=");
1380 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1381 cmddsc.dsc$w_length = strlen(cmd);
1383 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1384 flags = defflags | CLI$M_NOCLISYM;
1387 /* Create a new subprocess to execute each command, to exclude the
1388 * remote possibility that someone could subvert a mbx or file used
1389 * to write multiple commands to a single subprocess.
1392 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1393 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1394 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1395 defflags &= ~CLI$M_TRUSTED;
1396 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1398 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1399 if (seenhv) SvREFCNT_dec(seenhv);
1402 char *cp1, *cp2, *key;
1403 unsigned long int sts, iosb[2], retlen, keylen;
1406 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1407 if (sts & 1) sts = iosb[0] & 0xffff;
1408 if (sts == SS$_ENDOFFILE) {
1410 while (substs == 0) { sys$hiber(); wakect++;}
1411 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1416 retlen = iosb[0] >> 16;
1417 if (!retlen) continue; /* blank line */
1419 if (iosb[1] != subpid) {
1421 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1425 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1426 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1428 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1429 if (*cp1 == '(' || /* Logical name table name */
1430 *cp1 == '=' /* Next eqv of searchlist */) continue;
1431 if (*cp1 == '"') cp1++;
1432 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1433 key = cp1; keylen = cp2 - cp1;
1434 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1435 while (*cp2 && *cp2 != '=') cp2++;
1436 while (*cp2 && *cp2 == '=') cp2++;
1437 while (*cp2 && *cp2 == ' ') cp2++;
1438 if (*cp2 == '"') { /* String translation; may embed "" */
1439 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1440 cp2++; cp1--; /* Skip "" surrounding translation */
1442 else { /* Numeric translation */
1443 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1444 cp1--; /* stop on last non-space char */
1446 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1447 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1450 PERL_HASH(hash,key,keylen);
1452 if (cp1 == cp2 && *cp2 == '.') {
1453 /* A single dot usually means an unprintable character, such as a null
1454 * to indicate a zero-length value. Get the actual value to make sure.
1456 char lnm[LNM$C_NAMLENGTH+1];
1457 char eqv[MAX_DCL_SYMBOL+1];
1459 strncpy(lnm, key, keylen);
1460 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1461 sv = newSVpvn(eqv, strlen(eqv));
1464 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1468 hv_store(envhv,key,keylen,sv,hash);
1469 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1471 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1472 /* get the PPFs for this process, not the subprocess */
1473 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1474 char eqv[LNM$C_NAMLENGTH+1];
1476 for (i = 0; ppfs[i]; i++) {
1477 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1478 sv = newSVpv(eqv,trnlen);
1480 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1485 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1486 if (buf) Safefree(buf);
1487 if (seenhv) SvREFCNT_dec(seenhv);
1488 MUTEX_UNLOCK(&primenv_mutex);
1491 } /* end of prime_env_iter */
1495 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1496 /* Define or delete an element in the same "environment" as
1497 * vmstrnenv(). If an element is to be deleted, it's removed from
1498 * the first place it's found. If it's to be set, it's set in the
1499 * place designated by the first element of the table vector.
1500 * Like setenv() returns 0 for success, non-zero on error.
1503 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1506 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1507 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1509 unsigned long int retsts, usermode = PSL$C_USER;
1510 struct itmlst_3 *ile, *ilist;
1511 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1512 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1513 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1514 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1515 $DESCRIPTOR(local,"_LOCAL");
1518 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1519 return SS$_IVLOGNAM;
1522 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1523 *cp2 = _toupper(*cp1);
1524 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1525 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1526 return SS$_IVLOGNAM;
1529 lnmdsc.dsc$w_length = cp1 - lnm;
1530 if (!tabvec || !*tabvec) tabvec = env_tables;
1532 if (!eqv) { /* we're deleting n element */
1533 for (curtab = 0; tabvec[curtab]; curtab++) {
1534 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1536 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1537 if ((cp1 = strchr(environ[i],'=')) &&
1538 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1539 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1541 return setenv(lnm,"",1) ? vaxc$errno : 0;
1544 ivenv = 1; retsts = SS$_NOLOGNAM;
1546 if (ckWARN(WARN_INTERNAL))
1547 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1548 ivenv = 1; retsts = SS$_NOSUCHPGM;
1554 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1555 !str$case_blind_compare(&tmpdsc,&clisym)) {
1556 unsigned int symtype;
1557 if (tabvec[curtab]->dsc$w_length == 12 &&
1558 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1559 !str$case_blind_compare(&tmpdsc,&local))
1560 symtype = LIB$K_CLI_LOCAL_SYM;
1561 else symtype = LIB$K_CLI_GLOBAL_SYM;
1562 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1563 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1564 if (retsts == LIB$_NOSUCHSYM) continue;
1568 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1569 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1570 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1571 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1572 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1576 else { /* we're defining a value */
1577 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1579 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1581 if (ckWARN(WARN_INTERNAL))
1582 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1583 retsts = SS$_NOSUCHPGM;
1587 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1588 eqvdsc.dsc$w_length = strlen(eqv);
1589 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1590 !str$case_blind_compare(&tmpdsc,&clisym)) {
1591 unsigned int symtype;
1592 if (tabvec[0]->dsc$w_length == 12 &&
1593 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1594 !str$case_blind_compare(&tmpdsc,&local))
1595 symtype = LIB$K_CLI_LOCAL_SYM;
1596 else symtype = LIB$K_CLI_GLOBAL_SYM;
1597 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1600 if (!*eqv) eqvdsc.dsc$w_length = 1;
1601 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1603 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1604 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1605 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1606 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1607 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1608 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1611 Newx(ilist,nseg+1,struct itmlst_3);
1614 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1617 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1619 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1620 ile->itmcode = LNM$_STRING;
1622 if ((j+1) == nseg) {
1623 ile->buflen = strlen(c);
1624 /* in case we are truncating one that's too long */
1625 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1628 ile->buflen = LNM$C_NAMLENGTH;
1632 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1636 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1641 if (!(retsts & 1)) {
1643 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1644 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1645 set_errno(EVMSERR); break;
1646 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1647 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1648 set_errno(EINVAL); break;
1650 set_errno(EACCES); break;
1655 set_vaxc_errno(retsts);
1656 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1659 /* We reset error values on success because Perl does an hv_fetch()
1660 * before each hv_store(), and if the thing we're setting didn't
1661 * previously exist, we've got a leftover error message. (Of course,
1662 * this fails in the face of
1663 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1664 * in that the error reported in $! isn't spurious,
1665 * but it's right more often than not.)
1667 set_errno(0); set_vaxc_errno(retsts);
1671 } /* end of vmssetenv() */
1674 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1675 /* This has to be a function since there's a prototype for it in proto.h */
1677 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1680 int len = strlen(lnm);
1684 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1685 if (!strcmp(uplnm,"DEFAULT")) {
1686 if (eqv && *eqv) my_chdir(eqv);
1690 #ifndef RTL_USES_UTC
1691 if (len == 6 || len == 2) {
1694 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1696 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1697 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1701 (void) vmssetenv(lnm,eqv,NULL);
1705 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1707 * sets a user-mode logical in the process logical name table
1708 * used for redirection of sys$error
1711 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1713 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1714 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1715 unsigned long int iss, attr = LNM$M_CONFINE;
1716 unsigned char acmode = PSL$C_USER;
1717 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1719 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1720 d_name.dsc$w_length = strlen(name);
1722 lnmlst[0].buflen = strlen(eqv);
1723 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1725 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1726 if (!(iss&1)) lib$signal(iss);
1731 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1732 /* my_crypt - VMS password hashing
1733 * my_crypt() provides an interface compatible with the Unix crypt()
1734 * C library function, and uses sys$hash_password() to perform VMS
1735 * password hashing. The quadword hashed password value is returned
1736 * as a NUL-terminated 8 character string. my_crypt() does not change
1737 * the case of its string arguments; in order to match the behavior
1738 * of LOGINOUT et al., alphabetic characters in both arguments must
1739 * be upcased by the caller.
1741 * - fix me to call ACM services when available
1744 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1746 # ifndef UAI$C_PREFERRED_ALGORITHM
1747 # define UAI$C_PREFERRED_ALGORITHM 127
1749 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1750 unsigned short int salt = 0;
1751 unsigned long int sts;
1753 unsigned short int dsc$w_length;
1754 unsigned char dsc$b_type;
1755 unsigned char dsc$b_class;
1756 const char * dsc$a_pointer;
1757 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1758 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1759 struct itmlst_3 uailst[3] = {
1760 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1761 { sizeof salt, UAI$_SALT, &salt, 0},
1762 { 0, 0, NULL, NULL}};
1763 static char hash[9];
1765 usrdsc.dsc$w_length = strlen(usrname);
1766 usrdsc.dsc$a_pointer = usrname;
1767 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1769 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1773 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1778 set_vaxc_errno(sts);
1779 if (sts != RMS$_RNF) return NULL;
1782 txtdsc.dsc$w_length = strlen(textpasswd);
1783 txtdsc.dsc$a_pointer = textpasswd;
1784 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1785 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1788 return (char *) hash;
1790 } /* end of my_crypt() */
1794 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1795 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1796 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1798 /* fixup barenames that are directories for internal use.
1799 * There have been problems with the consistent handling of UNIX
1800 * style directory names when routines are presented with a name that
1801 * has no directory delimitors at all. So this routine will eventually
1804 static char * fixup_bare_dirnames(const char * name)
1806 if (decc_disable_to_vms_logname_translation) {
1812 /* 8.3, remove() is now broken on symbolic links */
1813 static int rms_erase(const char * vmsname);
1817 * A little hack to get around a bug in some implemenation of remove()
1818 * that do not know how to delete a directory
1820 * Delete any file to which user has control access, regardless of whether
1821 * delete access is explicitly allowed.
1822 * Limitations: User must have write access to parent directory.
1823 * Does not block signals or ASTs; if interrupted in midstream
1824 * may leave file with an altered ACL.
1827 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1829 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1833 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1834 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1835 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1837 unsigned char myace$b_length;
1838 unsigned char myace$b_type;
1839 unsigned short int myace$w_flags;
1840 unsigned long int myace$l_access;
1841 unsigned long int myace$l_ident;
1842 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1843 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1844 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1846 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1847 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1848 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1849 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1850 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1851 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1853 /* Expand the input spec using RMS, since the CRTL remove() and
1854 * system services won't do this by themselves, so we may miss
1855 * a file "hiding" behind a logical name or search list. */
1856 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1857 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1859 rslt = do_rmsexpand(name,
1863 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1867 PerlMem_free(vmsname);
1871 /* Erase the file */
1872 rmsts = rms_erase(vmsname);
1874 /* Did it succeed */
1875 if ($VMS_STATUS_SUCCESS(rmsts)) {
1876 PerlMem_free(vmsname);
1880 /* If not, can changing protections help? */
1881 if (rmsts != RMS$_PRV) {
1882 set_vaxc_errno(rmsts);
1883 PerlMem_free(vmsname);
1887 /* No, so we get our own UIC to use as a rights identifier,
1888 * and the insert an ACE at the head of the ACL which allows us
1889 * to delete the file.
1891 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1892 fildsc.dsc$w_length = strlen(vmsname);
1893 fildsc.dsc$a_pointer = vmsname;
1895 newace.myace$l_ident = oldace.myace$l_ident;
1897 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1899 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1900 set_errno(ENOENT); break;
1902 set_errno(ENOTDIR); break;
1904 set_errno(ENODEV); break;
1905 case RMS$_SYN: case SS$_INVFILFOROP:
1906 set_errno(EINVAL); break;
1908 set_errno(EACCES); break;
1912 set_vaxc_errno(aclsts);
1913 PerlMem_free(vmsname);
1916 /* Grab any existing ACEs with this identifier in case we fail */
1917 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1918 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1919 || fndsts == SS$_NOMOREACE ) {
1920 /* Add the new ACE . . . */
1921 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1924 rmsts = rms_erase(vmsname);
1925 if ($VMS_STATUS_SUCCESS(rmsts)) {
1930 /* We blew it - dir with files in it, no write priv for
1931 * parent directory, etc. Put things back the way they were. */
1932 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1935 addlst[0].bufadr = &oldace;
1936 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1943 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1944 /* We just deleted it, so of course it's not there. Some versions of
1945 * VMS seem to return success on the unlock operation anyhow (after all
1946 * the unlock is successful), but others don't.
1948 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1949 if (aclsts & 1) aclsts = fndsts;
1950 if (!(aclsts & 1)) {
1952 set_vaxc_errno(aclsts);
1955 PerlMem_free(vmsname);
1958 } /* end of kill_file() */
1962 /*{{{int do_rmdir(char *name)*/
1964 Perl_do_rmdir(pTHX_ const char *name)
1970 dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1971 if (dirfile == NULL)
1972 _ckvmssts(SS$_INSFMEM);
1974 /* Force to a directory specification */
1975 if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1976 PerlMem_free(dirfile);
1979 if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
1984 retval = mp_do_kill_file(aTHX_ dirfile, 1);
1986 PerlMem_free(dirfile);
1989 } /* end of do_rmdir */
1993 * Delete any file to which user has control access, regardless of whether
1994 * delete access is explicitly allowed.
1995 * Limitations: User must have write access to parent directory.
1996 * Does not block signals or ASTs; if interrupted in midstream
1997 * may leave file with an altered ACL.
2000 /*{{{int kill_file(char *name)*/
2002 Perl_kill_file(pTHX_ const char *name)
2004 char rspec[NAM$C_MAXRSS+1];
2009 /* Remove() is allowed to delete directories, according to the X/Open
2011 * This may need special handling to work with the ACL hacks.
2013 if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2014 rmsts = Perl_do_rmdir(aTHX_ name);
2018 rmsts = mp_do_kill_file(aTHX_ name, 0);
2022 } /* end of kill_file() */
2026 /*{{{int my_mkdir(char *,Mode_t)*/
2028 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2030 STRLEN dirlen = strlen(dir);
2032 /* zero length string sometimes gives ACCVIO */
2033 if (dirlen == 0) return -1;
2035 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2036 * null file name/type. However, it's commonplace under Unix,
2037 * so we'll allow it for a gain in portability.
2039 if (dir[dirlen-1] == '/') {
2040 char *newdir = savepvn(dir,dirlen-1);
2041 int ret = mkdir(newdir,mode);
2045 else return mkdir(dir,mode);
2046 } /* end of my_mkdir */
2049 /*{{{int my_chdir(char *)*/
2051 Perl_my_chdir(pTHX_ const char *dir)
2053 STRLEN dirlen = strlen(dir);
2055 /* zero length string sometimes gives ACCVIO */
2056 if (dirlen == 0) return -1;
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.
2064 while ((dirlen > 0) && (*dir1 == ' ')) {
2069 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2071 * null file name/type. However, it's commonplace under Unix,
2072 * so we'll allow it for a gain in portability.
2074 * - Preview- '/' will be valid soon on VMS
2076 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2077 char *newdir = savepvn(dir1,dirlen-1);
2078 int ret = chdir(newdir);
2082 else return chdir(dir1);
2083 } /* end of my_chdir */
2087 /*{{{int my_chmod(char *, mode_t)*/
2089 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2091 STRLEN speclen = strlen(file_spec);
2093 /* zero length string sometimes gives ACCVIO */
2094 if (speclen == 0) return -1;
2096 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2097 * that implies null file name/type. However, it's commonplace under Unix,
2098 * so we'll allow it for a gain in portability.
2100 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2101 * in VMS file.dir notation.
2103 if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2104 char *vms_src, *vms_dir, *rslt;
2108 /* First convert this to a VMS format specification */
2109 vms_src = PerlMem_malloc(VMS_MAXRSS);
2110 if (vms_src == NULL)
2111 _ckvmssts(SS$_INSFMEM);
2113 rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2115 /* If we fail, then not a file specification */
2116 PerlMem_free(vms_src);
2121 /* Now make it a directory spec so chmod is happy */
2122 vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2123 if (vms_dir == NULL)
2124 _ckvmssts(SS$_INSFMEM);
2125 rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2126 PerlMem_free(vms_src);
2130 ret = chmod(vms_dir, mode);
2134 PerlMem_free(vms_dir);
2137 else return chmod(file_spec, mode);
2138 } /* end of my_chmod */
2142 /*{{{FILE *my_tmpfile()*/
2149 if ((fp = tmpfile())) return fp;
2151 cp = PerlMem_malloc(L_tmpnam+24);
2152 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2154 if (decc_filename_unix_only == 0)
2155 strcpy(cp,"Sys$Scratch:");
2158 tmpnam(cp+strlen(cp));
2159 strcat(cp,".Perltmp");
2160 fp = fopen(cp,"w+","fop=dlt");
2167 #ifndef HOMEGROWN_POSIX_SIGNALS
2169 * The C RTL's sigaction fails to check for invalid signal numbers so we
2170 * help it out a bit. The docs are correct, but the actual routine doesn't
2171 * do what the docs say it will.
2173 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2175 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2176 struct sigaction* oact)
2178 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2179 SETERRNO(EINVAL, SS$_INVARG);
2182 return sigaction(sig, act, oact);
2187 #ifdef KILL_BY_SIGPRC
2188 #include <errnodef.h>
2190 /* We implement our own kill() using the undocumented system service
2191 sys$sigprc for one of two reasons:
2193 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2194 target process to do a sys$exit, which usually can't be handled
2195 gracefully...certainly not by Perl and the %SIG{} mechanism.
2197 2.) If the kill() in the CRTL can't be called from a signal
2198 handler without disappearing into the ether, i.e., the signal
2199 it purportedly sends is never trapped. Still true as of VMS 7.3.
2201 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2202 in the target process rather than calling sys$exit.
2204 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2205 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2206 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2207 with condition codes C$_SIG0+nsig*8, catching the exception on the
2208 target process and resignaling with appropriate arguments.
2210 But we don't have that VMS 7.0+ exception handler, so if you
2211 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2213 Also note that SIGTERM is listed in the docs as being "unimplemented",
2214 yet always seems to be signaled with a VMS condition code of 4 (and
2215 correctly handled for that code). So we hardwire it in.
2217 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2218 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2219 than signalling with an unrecognized (and unhandled by CRTL) code.
2222 #define _MY_SIG_MAX 28
2225 Perl_sig_to_vmscondition_int(int sig)
2227 static unsigned int sig_code[_MY_SIG_MAX+1] =
2230 SS$_HANGUP, /* 1 SIGHUP */
2231 SS$_CONTROLC, /* 2 SIGINT */
2232 SS$_CONTROLY, /* 3 SIGQUIT */
2233 SS$_RADRMOD, /* 4 SIGILL */
2234 SS$_BREAK, /* 5 SIGTRAP */
2235 SS$_OPCCUS, /* 6 SIGABRT */
2236 SS$_COMPAT, /* 7 SIGEMT */
2238 SS$_FLTOVF, /* 8 SIGFPE VAX */
2240 SS$_HPARITH, /* 8 SIGFPE AXP */
2242 SS$_ABORT, /* 9 SIGKILL */
2243 SS$_ACCVIO, /* 10 SIGBUS */
2244 SS$_ACCVIO, /* 11 SIGSEGV */
2245 SS$_BADPARAM, /* 12 SIGSYS */
2246 SS$_NOMBX, /* 13 SIGPIPE */
2247 SS$_ASTFLT, /* 14 SIGALRM */
2264 #if __VMS_VER >= 60200000
2265 static int initted = 0;
2268 sig_code[16] = C$_SIGUSR1;
2269 sig_code[17] = C$_SIGUSR2;
2270 #if __CRTL_VER >= 70000000
2271 sig_code[20] = C$_SIGCHLD;
2273 #if __CRTL_VER >= 70300000
2274 sig_code[28] = C$_SIGWINCH;
2279 if (sig < _SIG_MIN) return 0;
2280 if (sig > _MY_SIG_MAX) return 0;
2281 return sig_code[sig];
2285 Perl_sig_to_vmscondition(int sig)
2288 if (vms_debug_on_exception != 0)
2289 lib$signal(SS$_DEBUG);
2291 return Perl_sig_to_vmscondition_int(sig);
2296 Perl_my_kill(int pid, int sig)
2301 int sys$sigprc(unsigned int *pidadr,
2302 struct dsc$descriptor_s *prcname,
2305 /* sig 0 means validate the PID */
2306 /*------------------------------*/
2308 const unsigned long int jpicode = JPI$_PID;
2311 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2312 if ($VMS_STATUS_SUCCESS(status))
2315 case SS$_NOSUCHNODE:
2316 case SS$_UNREACHABLE:
2330 code = Perl_sig_to_vmscondition_int(sig);
2333 SETERRNO(EINVAL, SS$_BADPARAM);
2337 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2338 * signals are to be sent to multiple processes.
2339 * pid = 0 - all processes in group except ones that the system exempts
2340 * pid = -1 - all processes except ones that the system exempts
2341 * pid = -n - all processes in group (abs(n)) except ...
2342 * For now, just report as not supported.
2346 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2350 iss = sys$sigprc((unsigned int *)&pid,0,code);
2351 if (iss&1) return 0;
2355 set_errno(EPERM); break;
2357 case SS$_NOSUCHNODE:
2358 case SS$_UNREACHABLE:
2359 set_errno(ESRCH); break;
2361 set_errno(ENOMEM); break;
2366 set_vaxc_errno(iss);
2372 /* Routine to convert a VMS status code to a UNIX status code.
2373 ** More tricky than it appears because of conflicting conventions with
2376 ** VMS status codes are a bit mask, with the least significant bit set for
2379 ** Special UNIX status of EVMSERR indicates that no translation is currently
2380 ** available, and programs should check the VMS status code.
2382 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2386 #ifndef C_FACILITY_NO
2387 #define C_FACILITY_NO 0x350000
2390 #define DCL_IVVERB 0x38090
2393 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2401 /* Assume the best or the worst */
2402 if (vms_status & STS$M_SUCCESS)
2405 unix_status = EVMSERR;
2407 msg_status = vms_status & ~STS$M_CONTROL;
2409 facility = vms_status & STS$M_FAC_NO;
2410 fac_sp = vms_status & STS$M_FAC_SP;
2411 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2413 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2419 unix_status = EFAULT;
2421 case SS$_DEVOFFLINE:
2422 unix_status = EBUSY;
2425 unix_status = ENOTCONN;
2433 case SS$_INVFILFOROP:
2437 unix_status = EINVAL;
2439 case SS$_UNSUPPORTED:
2440 unix_status = ENOTSUP;
2445 unix_status = EACCES;
2447 case SS$_DEVICEFULL:
2448 unix_status = ENOSPC;
2451 unix_status = ENODEV;
2453 case SS$_NOSUCHFILE:
2454 case SS$_NOSUCHOBJECT:
2455 unix_status = ENOENT;
2457 case SS$_ABORT: /* Fatal case */
2458 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2459 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2460 unix_status = EINTR;
2463 unix_status = E2BIG;
2466 unix_status = ENOMEM;
2469 unix_status = EPERM;
2471 case SS$_NOSUCHNODE:
2472 case SS$_UNREACHABLE:
2473 unix_status = ESRCH;
2476 unix_status = ECHILD;
2479 if ((facility == 0) && (msg_no < 8)) {
2480 /* These are not real VMS status codes so assume that they are
2481 ** already UNIX status codes
2483 unix_status = msg_no;
2489 /* Translate a POSIX exit code to a UNIX exit code */
2490 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2491 unix_status = (msg_no & 0x07F8) >> 3;
2495 /* Documented traditional behavior for handling VMS child exits */
2496 /*--------------------------------------------------------------*/
2497 if (child_flag != 0) {
2499 /* Success / Informational return 0 */
2500 /*----------------------------------*/
2501 if (msg_no & STS$K_SUCCESS)
2504 /* Warning returns 1 */
2505 /*-------------------*/
2506 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2509 /* Everything else pass through the severity bits */
2510 /*------------------------------------------------*/
2511 return (msg_no & STS$M_SEVERITY);
2514 /* Normal VMS status to ERRNO mapping attempt */
2515 /*--------------------------------------------*/
2516 switch(msg_status) {
2517 /* case RMS$_EOF: */ /* End of File */
2518 case RMS$_FNF: /* File Not Found */
2519 case RMS$_DNF: /* Dir Not Found */
2520 unix_status = ENOENT;
2522 case RMS$_RNF: /* Record Not Found */
2523 unix_status = ESRCH;
2526 unix_status = ENOTDIR;
2529 unix_status = ENODEV;
2534 unix_status = EBADF;
2537 unix_status = EEXIST;
2541 case LIB$_INVSTRDES:
2543 case LIB$_NOSUCHSYM:
2544 case LIB$_INVSYMNAM:
2546 unix_status = EINVAL;
2552 unix_status = E2BIG;
2554 case RMS$_PRV: /* No privilege */
2555 case RMS$_ACC: /* ACP file access failed */
2556 case RMS$_WLK: /* Device write locked */
2557 unix_status = EACCES;
2559 /* case RMS$_NMF: */ /* No more files */
2567 /* Try to guess at what VMS error status should go with a UNIX errno
2568 * value. This is hard to do as there could be many possible VMS
2569 * error statuses that caused the errno value to be set.
2572 int Perl_unix_status_to_vms(int unix_status)
2574 int test_unix_status;
2576 /* Trivial cases first */
2577 /*---------------------*/
2578 if (unix_status == EVMSERR)
2581 /* Is vaxc$errno sane? */
2582 /*---------------------*/
2583 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2584 if (test_unix_status == unix_status)
2587 /* If way out of range, must be VMS code already */
2588 /*-----------------------------------------------*/
2589 if (unix_status > EVMSERR)
2592 /* If out of range, punt */
2593 /*-----------------------*/
2594 if (unix_status > __ERRNO_MAX)
2598 /* Ok, now we have to do it the hard way. */
2599 /*----------------------------------------*/
2600 switch(unix_status) {
2601 case 0: return SS$_NORMAL;
2602 case EPERM: return SS$_NOPRIV;
2603 case ENOENT: return SS$_NOSUCHOBJECT;
2604 case ESRCH: return SS$_UNREACHABLE;
2605 case EINTR: return SS$_ABORT;
2608 case E2BIG: return SS$_BUFFEROVF;
2610 case EBADF: return RMS$_IFI;
2611 case ECHILD: return SS$_NONEXPR;
2613 case ENOMEM: return SS$_INSFMEM;
2614 case EACCES: return SS$_FILACCERR;
2615 case EFAULT: return SS$_ACCVIO;
2617 case EBUSY: return SS$_DEVOFFLINE;
2618 case EEXIST: return RMS$_FEX;
2620 case ENODEV: return SS$_NOSUCHDEV;
2621 case ENOTDIR: return RMS$_DIR;
2623 case EINVAL: return SS$_INVARG;
2629 case ENOSPC: return SS$_DEVICEFULL;
2630 case ESPIPE: return LIB$_INVARG;
2635 case ERANGE: return LIB$_INVARG;
2636 /* case EWOULDBLOCK */
2637 /* case EINPROGRESS */
2640 /* case EDESTADDRREQ */
2642 /* case EPROTOTYPE */
2643 /* case ENOPROTOOPT */
2644 /* case EPROTONOSUPPORT */
2645 /* case ESOCKTNOSUPPORT */
2646 /* case EOPNOTSUPP */
2647 /* case EPFNOSUPPORT */
2648 /* case EAFNOSUPPORT */
2649 /* case EADDRINUSE */
2650 /* case EADDRNOTAVAIL */
2652 /* case ENETUNREACH */
2653 /* case ENETRESET */
2654 /* case ECONNABORTED */
2655 /* case ECONNRESET */
2658 case ENOTCONN: return SS$_CLEARED;
2659 /* case ESHUTDOWN */
2660 /* case ETOOMANYREFS */
2661 /* case ETIMEDOUT */
2662 /* case ECONNREFUSED */
2664 /* case ENAMETOOLONG */
2665 /* case EHOSTDOWN */
2666 /* case EHOSTUNREACH */
2667 /* case ENOTEMPTY */
2679 /* case ECANCELED */
2683 return SS$_UNSUPPORTED;
2689 /* case EABANDONED */
2691 return SS$_ABORT; /* punt */
2694 return SS$_ABORT; /* Should not get here */
2698 /* default piping mailbox size */
2699 #define PERL_BUFSIZ 512
2703 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2705 unsigned long int mbxbufsiz;
2706 static unsigned long int syssize = 0;
2707 unsigned long int dviitm = DVI$_DEVNAM;
2708 char csize[LNM$C_NAMLENGTH+1];
2712 unsigned long syiitm = SYI$_MAXBUF;
2714 * Get the SYSGEN parameter MAXBUF
2716 * If the logical 'PERL_MBX_SIZE' is defined
2717 * use the value of the logical instead of PERL_BUFSIZ, but
2718 * keep the size between 128 and MAXBUF.
2721 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2724 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2725 mbxbufsiz = atoi(csize);
2727 mbxbufsiz = PERL_BUFSIZ;
2729 if (mbxbufsiz < 128) mbxbufsiz = 128;
2730 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2732 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2734 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2735 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2737 } /* end of create_mbx() */
2740 /*{{{ my_popen and my_pclose*/
2742 typedef struct _iosb IOSB;
2743 typedef struct _iosb* pIOSB;
2744 typedef struct _pipe Pipe;
2745 typedef struct _pipe* pPipe;
2746 typedef struct pipe_details Info;
2747 typedef struct pipe_details* pInfo;
2748 typedef struct _srqp RQE;
2749 typedef struct _srqp* pRQE;
2750 typedef struct _tochildbuf CBuf;
2751 typedef struct _tochildbuf* pCBuf;
2754 unsigned short status;
2755 unsigned short count;
2756 unsigned long dvispec;
2759 #pragma member_alignment save
2760 #pragma nomember_alignment quadword
2761 struct _srqp { /* VMS self-relative queue entry */
2762 unsigned long qptr[2];
2764 #pragma member_alignment restore
2765 static RQE RQE_ZERO = {0,0};
2767 struct _tochildbuf {
2770 unsigned short size;
2778 unsigned short chan_in;
2779 unsigned short chan_out;
2781 unsigned int bufsize;
2793 #if defined(PERL_IMPLICIT_CONTEXT)
2794 void *thx; /* Either a thread or an interpreter */
2795 /* pointer, depending on how we're built */
2803 PerlIO *fp; /* file pointer to pipe mailbox */
2804 int useFILE; /* using stdio, not perlio */
2805 int pid; /* PID of subprocess */
2806 int mode; /* == 'r' if pipe open for reading */
2807 int done; /* subprocess has completed */
2808 int waiting; /* waiting for completion/closure */
2809 int closing; /* my_pclose is closing this pipe */
2810 unsigned long completion; /* termination status of subprocess */
2811 pPipe in; /* pipe in to sub */
2812 pPipe out; /* pipe out of sub */
2813 pPipe err; /* pipe of sub's sys$error */
2814 int in_done; /* true when in pipe finished */
2817 unsigned short xchan; /* channel to debug xterm */
2818 unsigned short xchan_valid; /* channel is assigned */
2821 struct exit_control_block
2823 struct exit_control_block *flink;
2824 unsigned long int (*exit_routine)();
2825 unsigned long int arg_count;
2826 unsigned long int *status_address;
2827 unsigned long int exit_status;
2830 typedef struct _closed_pipes Xpipe;
2831 typedef struct _closed_pipes* pXpipe;
2833 struct _closed_pipes {
2834 int pid; /* PID of subprocess */
2835 unsigned long completion; /* termination status of subprocess */
2837 #define NKEEPCLOSED 50
2838 static Xpipe closed_list[NKEEPCLOSED];
2839 static int closed_index = 0;
2840 static int closed_num = 0;
2842 #define RETRY_DELAY "0 ::0.20"
2843 #define MAX_RETRY 50
2845 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2846 static unsigned long mypid;
2847 static unsigned long delaytime[2];
2849 static pInfo open_pipes = NULL;
2850 static $DESCRIPTOR(nl_desc, "NL:");
2852 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2856 static unsigned long int
2857 pipe_exit_routine(pTHX)
2860 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2861 int sts, did_stuff, need_eof, j;
2864 * Flush any pending i/o, but since we are in process run-down, be
2865 * careful about referencing PerlIO structures that may already have
2866 * been deallocated. We may not even have an interpreter anymore.
2872 #if defined(USE_ITHREADS)
2875 && PL_perlio_fd_refcnt)
2876 PerlIO_flush(info->fp);
2878 fflush((FILE *)info->fp);
2884 next we try sending an EOF...ignore if doesn't work, make sure we
2892 _ckvmssts_noperl(sys$setast(0));
2893 if (info->in && !info->in->shut_on_empty) {
2894 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2899 _ckvmssts_noperl(sys$setast(1));
2903 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2905 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2910 _ckvmssts_noperl(sys$setast(0));
2911 if (info->waiting && info->done)
2913 nwait += info->waiting;
2914 _ckvmssts_noperl(sys$setast(1));
2924 _ckvmssts_noperl(sys$setast(0));
2925 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2926 sts = sys$forcex(&info->pid,0,&abort);
2927 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2930 _ckvmssts_noperl(sys$setast(1));
2934 /* again, wait for effect */
2936 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2941 _ckvmssts_noperl(sys$setast(0));
2942 if (info->waiting && info->done)
2944 nwait += info->waiting;
2945 _ckvmssts_noperl(sys$setast(1));
2954 _ckvmssts_noperl(sys$setast(0));
2955 if (!info->done) { /* We tried to be nice . . . */
2956 sts = sys$delprc(&info->pid,0);
2957 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2958 info->done = 1; /* sys$delprc is as done as we're going to get. */
2960 _ckvmssts_noperl(sys$setast(1));
2965 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2966 else if (!(sts & 1)) retsts = sts;
2971 static struct exit_control_block pipe_exitblock =
2972 {(struct exit_control_block *) 0,
2973 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2975 static void pipe_mbxtofd_ast(pPipe p);
2976 static void pipe_tochild1_ast(pPipe p);
2977 static void pipe_tochild2_ast(pPipe p);
2980 popen_completion_ast(pInfo info)
2982 pInfo i = open_pipes;
2987 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2988 closed_list[closed_index].pid = info->pid;
2989 closed_list[closed_index].completion = info->completion;
2991 if (closed_index == NKEEPCLOSED)
2996 if (i == info) break;
2999 if (!i) return; /* unlinked, probably freed too */
3004 Writing to subprocess ...
3005 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3007 chan_out may be waiting for "done" flag, or hung waiting
3008 for i/o completion to child...cancel the i/o. This will
3009 put it into "snarf mode" (done but no EOF yet) that discards
3012 Output from subprocess (stdout, stderr) needs to be flushed and
3013 shut down. We try sending an EOF, but if the mbx is full the pipe
3014 routine should still catch the "shut_on_empty" flag, telling it to
3015 use immediate-style reads so that "mbx empty" -> EOF.
3019 if (info->in && !info->in_done) { /* only for mode=w */
3020 if (info->in->shut_on_empty && info->in->need_wake) {
3021 info->in->need_wake = FALSE;
3022 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3024 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3028 if (info->out && !info->out_done) { /* were we also piping output? */
3029 info->out->shut_on_empty = TRUE;
3030 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3031 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3032 _ckvmssts_noperl(iss);
3035 if (info->err && !info->err_done) { /* we were piping stderr */
3036 info->err->shut_on_empty = TRUE;
3037 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3038 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3039 _ckvmssts_noperl(iss);
3041 _ckvmssts_noperl(sys$setef(pipe_ef));
3045 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3046 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3049 we actually differ from vmstrnenv since we use this to
3050 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3051 are pointing to the same thing
3054 static unsigned short
3055 popen_translate(pTHX_ char *logical, char *result)
3058 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3059 $DESCRIPTOR(d_log,"");
3061 unsigned short length;
3062 unsigned short code;
3064 unsigned short *retlenaddr;
3066 unsigned short l, ifi;
3068 d_log.dsc$a_pointer = logical;
3069 d_log.dsc$w_length = strlen(logical);
3071 itmlst[0].code = LNM$_STRING;
3072 itmlst[0].length = 255;
3073 itmlst[0].buffer_addr = result;
3074 itmlst[0].retlenaddr = &l;
3077 itmlst[1].length = 0;
3078 itmlst[1].buffer_addr = 0;
3079 itmlst[1].retlenaddr = 0;
3081 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3082 if (iss == SS$_NOLOGNAM) {
3086 if (!(iss&1)) lib$signal(iss);
3089 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3090 strip it off and return the ifi, if any
3093 if (result[0] == 0x1b && result[1] == 0x00) {
3094 memmove(&ifi,result+2,2);
3095 strcpy(result,result+4);
3097 return ifi; /* this is the RMS internal file id */
3100 static void pipe_infromchild_ast(pPipe p);
3103 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3104 inside an AST routine without worrying about reentrancy and which Perl
3105 memory allocator is being used.
3107 We read data and queue up the buffers, then spit them out one at a
3108 time to the output mailbox when the output mailbox is ready for one.
3111 #define INITIAL_TOCHILDQUEUE 2
3114 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3118 char mbx1[64], mbx2[64];
3119 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3120 DSC$K_CLASS_S, mbx1},
3121 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3122 DSC$K_CLASS_S, mbx2};
3123 unsigned int dviitm = DVI$_DEVBUFSIZ;
3127 _ckvmssts(lib$get_vm(&n, &p));
3129 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3130 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3131 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3134 p->shut_on_empty = FALSE;
3135 p->need_wake = FALSE;
3138 p->iosb.status = SS$_NORMAL;
3139 p->iosb2.status = SS$_NORMAL;
3145 #ifdef PERL_IMPLICIT_CONTEXT
3149 n = sizeof(CBuf) + p->bufsize;
3151 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3152 _ckvmssts(lib$get_vm(&n, &b));
3153 b->buf = (char *) b + sizeof(CBuf);
3154 _ckvmssts(lib$insqhi(b, &p->free));
3157 pipe_tochild2_ast(p);
3158 pipe_tochild1_ast(p);
3164 /* reads the MBX Perl is writing, and queues */
3167 pipe_tochild1_ast(pPipe p)
3170 int iss = p->iosb.status;
3171 int eof = (iss == SS$_ENDOFFILE);
3173 #ifdef PERL_IMPLICIT_CONTEXT
3179 p->shut_on_empty = TRUE;
3181 _ckvmssts(sys$dassgn(p->chan_in));
3187 b->size = p->iosb.count;
3188 _ckvmssts(sts = lib$insqhi(b, &p->wait));
3190 p->need_wake = FALSE;
3191 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3194 p->retry = 1; /* initial call */
3197 if (eof) { /* flush the free queue, return when done */
3198 int n = sizeof(CBuf) + p->bufsize;
3200 iss = lib$remqti(&p->free, &b);
3201 if (iss == LIB$_QUEWASEMP) return;
3203 _ckvmssts(lib$free_vm(&n, &b));
3207 iss = lib$remqti(&p->free, &b);
3208 if (iss == LIB$_QUEWASEMP) {
3209 int n = sizeof(CBuf) + p->bufsize;
3210 _ckvmssts(lib$get_vm(&n, &b));
3211 b->buf = (char *) b + sizeof(CBuf);
3217 iss = sys$qio(0,p->chan_in,
3218 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3220 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3221 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3226 /* writes queued buffers to output, waits for each to complete before
3230 pipe_tochild2_ast(pPipe p)
3233 int iss = p->iosb2.status;
3234 int n = sizeof(CBuf) + p->bufsize;
3235 int done = (p->info && p->info->done) ||
3236 iss == SS$_CANCEL || iss == SS$_ABORT;
3237 #if defined(PERL_IMPLICIT_CONTEXT)
3242 if (p->type) { /* type=1 has old buffer, dispose */
3243 if (p->shut_on_empty) {
3244 _ckvmssts(lib$free_vm(&n, &b));
3246 _ckvmssts(lib$insqhi(b, &p->free));
3251 iss = lib$remqti(&p->wait, &b);
3252 if (iss == LIB$_QUEWASEMP) {
3253 if (p->shut_on_empty) {
3255 _ckvmssts(sys$dassgn(p->chan_out));
3256 *p->pipe_done = TRUE;
3257 _ckvmssts(sys$setef(pipe_ef));
3259 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3260 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3264 p->need_wake = TRUE;
3274 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3275 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3277 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3278 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3287 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3290 char mbx1[64], mbx2[64];
3291 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3292 DSC$K_CLASS_S, mbx1},
3293 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3294 DSC$K_CLASS_S, mbx2};
3295 unsigned int dviitm = DVI$_DEVBUFSIZ;
3297 int n = sizeof(Pipe);
3298 _ckvmssts(lib$get_vm(&n, &p));
3299 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3300 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3302 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3303 n = p->bufsize * sizeof(char);
3304 _ckvmssts(lib$get_vm(&n, &p->buf));
3305 p->shut_on_empty = FALSE;
3308 p->iosb.status = SS$_NORMAL;
3309 #if defined(PERL_IMPLICIT_CONTEXT)
3312 pipe_infromchild_ast(p);
3320 pipe_infromchild_ast(pPipe p)
3322 int iss = p->iosb.status;
3323 int eof = (iss == SS$_ENDOFFILE);
3324 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3325 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3326 #if defined(PERL_IMPLICIT_CONTEXT)
3330 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3331 _ckvmssts(sys$dassgn(p->chan_out));
3336 input shutdown if EOF from self (done or shut_on_empty)
3337 output shutdown if closing flag set (my_pclose)
3338 send data/eof from child or eof from self
3339 otherwise, re-read (snarf of data from child)
3344 if (myeof && p->chan_in) { /* input shutdown */
3345 _ckvmssts(sys$dassgn(p->chan_in));
3350 if (myeof || kideof) { /* pass EOF to parent */
3351 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3352 pipe_infromchild_ast, p,
3355 } else if (eof) { /* eat EOF --- fall through to read*/
3357 } else { /* transmit data */
3358 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3359 pipe_infromchild_ast,p,
3360 p->buf, p->iosb.count, 0, 0, 0, 0));
3366 /* everything shut? flag as done */
3368 if (!p->chan_in && !p->chan_out) {
3369 *p->pipe_done = TRUE;
3370 _ckvmssts(sys$setef(pipe_ef));
3374 /* write completed (or read, if snarfing from child)
3375 if still have input active,
3376 queue read...immediate mode if shut_on_empty so we get EOF if empty
3378 check if Perl reading, generate EOFs as needed
3384 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3385 pipe_infromchild_ast,p,
3386 p->buf, p->bufsize, 0, 0, 0, 0);
3387 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3389 } else { /* send EOFs for extra reads */
3390 p->iosb.status = SS$_ENDOFFILE;
3391 p->iosb.dvispec = 0;
3392 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3394 pipe_infromchild_ast, p, 0, 0, 0, 0));
3400 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3404 unsigned long dviitm = DVI$_DEVBUFSIZ;
3406 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3407 DSC$K_CLASS_S, mbx};
3408 int n = sizeof(Pipe);
3410 /* things like terminals and mbx's don't need this filter */
3411 if (fd && fstat(fd,&s) == 0) {
3412 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3414 unsigned short dev_len;
3415 struct dsc$descriptor_s d_dev;
3417 struct item_list_3 items[3];
3419 unsigned short dvi_iosb[4];
3421 cptr = getname(fd, out, 1);
3422 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3423 d_dev.dsc$a_pointer = out;
3424 d_dev.dsc$w_length = strlen(out);
3425 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3426 d_dev.dsc$b_class = DSC$K_CLASS_S;
3429 items[0].code = DVI$_DEVCHAR;
3430 items[0].bufadr = &devchar;
3431 items[0].retadr = NULL;
3433 items[1].code = DVI$_FULLDEVNAM;
3434 items[1].bufadr = device;
3435 items[1].retadr = &dev_len;
3439 status = sys$getdviw
3440 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3442 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3443 device[dev_len] = 0;
3445 if (!(devchar & DEV$M_DIR)) {
3446 strcpy(out, device);
3452 _ckvmssts(lib$get_vm(&n, &p));
3453 p->fd_out = dup(fd);
3454 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3455 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3456 n = (p->bufsize+1) * sizeof(char);
3457 _ckvmssts(lib$get_vm(&n, &p->buf));
3458 p->shut_on_empty = FALSE;
3463 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3464 pipe_mbxtofd_ast, p,
3465 p->buf, p->bufsize, 0, 0, 0, 0));
3471 pipe_mbxtofd_ast(pPipe p)
3473 int iss = p->iosb.status;
3474 int done = p->info->done;
3476 int eof = (iss == SS$_ENDOFFILE);
3477 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3478 int err = !(iss&1) && !eof;
3479 #if defined(PERL_IMPLICIT_CONTEXT)
3483 if (done && myeof) { /* end piping */
3485 sys$dassgn(p->chan_in);
3486 *p->pipe_done = TRUE;
3487 _ckvmssts(sys$setef(pipe_ef));
3491 if (!err && !eof) { /* good data to send to file */
3492 p->buf[p->iosb.count] = '\n';
3493 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3496 if (p->retry < MAX_RETRY) {
3497 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3507 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3508 pipe_mbxtofd_ast, p,
3509 p->buf, p->bufsize, 0, 0, 0, 0);
3510 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3515 typedef struct _pipeloc PLOC;
3516 typedef struct _pipeloc* pPLOC;
3520 char dir[NAM$C_MAXRSS+1];
3522 static pPLOC head_PLOC = 0;
3525 free_pipelocs(pTHX_ void *head)
3528 pPLOC *pHead = (pPLOC *)head;
3540 store_pipelocs(pTHX)
3549 char temp[NAM$C_MAXRSS+1];
3553 free_pipelocs(aTHX_ &head_PLOC);
3555 /* the . directory from @INC comes last */
3557 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3558 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3559 p->next = head_PLOC;
3561 strcpy(p->dir,"./");
3563 /* get the directory from $^X */
3565 unixdir = PerlMem_malloc(VMS_MAXRSS);
3566 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3568 #ifdef PERL_IMPLICIT_CONTEXT
3569 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3571 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3573 strcpy(temp, PL_origargv[0]);
3574 x = strrchr(temp,']');
3576 x = strrchr(temp,'>');
3578 /* It could be a UNIX path */
3579 x = strrchr(temp,'/');
3585 /* Got a bare name, so use default directory */
3590 if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3591 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3592 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3593 p->next = head_PLOC;
3595 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3596 p->dir[NAM$C_MAXRSS] = '\0';
3600 /* reverse order of @INC entries, skip "." since entered above */
3602 #ifdef PERL_IMPLICIT_CONTEXT
3605 if (PL_incgv) av = GvAVn(PL_incgv);
3607 for (i = 0; av && i <= AvFILL(av); i++) {
3608 dirsv = *av_fetch(av,i,TRUE);
3610 if (SvROK(dirsv)) continue;
3611 dir = SvPVx(dirsv,n_a);
3612 if (strcmp(dir,".") == 0) continue;
3613 if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3616 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3617 p->next = head_PLOC;
3619 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3620 p->dir[NAM$C_MAXRSS] = '\0';
3623 /* most likely spot (ARCHLIB) put first in the list */
3626 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3627 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3628 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3629 p->next = head_PLOC;
3631 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3632 p->dir[NAM$C_MAXRSS] = '\0';
3635 PerlMem_free(unixdir);
3639 Perl_cando_by_name_int
3640 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3641 #if !defined(PERL_IMPLICIT_CONTEXT)
3642 #define cando_by_name_int Perl_cando_by_name_int
3644 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3650 static int vmspipe_file_status = 0;
3651 static char vmspipe_file[NAM$C_MAXRSS+1];
3653 /* already found? Check and use ... need read+execute permission */
3655 if (vmspipe_file_status == 1) {
3656 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3657 && cando_by_name_int
3658 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3659 return vmspipe_file;
3661 vmspipe_file_status = 0;
3664 /* scan through stored @INC, $^X */
3666 if (vmspipe_file_status == 0) {
3667 char file[NAM$C_MAXRSS+1];
3668 pPLOC p = head_PLOC;
3673 strcpy(file, p->dir);
3674 dirlen = strlen(file);
3675 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3676 file[NAM$C_MAXRSS] = '\0';
3679 exp_res = do_rmsexpand
3680 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3681 if (!exp_res) continue;
3683 if (cando_by_name_int
3684 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3685 && cando_by_name_int
3686 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3687 vmspipe_file_status = 1;
3688 return vmspipe_file;
3691 vmspipe_file_status = -1; /* failed, use tempfiles */
3698 vmspipe_tempfile(pTHX)
3700 char file[NAM$C_MAXRSS+1];
3702 static int index = 0;
3706 /* create a tempfile */
3708 /* we can't go from W, shr=get to R, shr=get without
3709 an intermediate vulnerable state, so don't bother trying...
3711 and lib$spawn doesn't shr=put, so have to close the write
3713 So... match up the creation date/time and the FID to
3714 make sure we're dealing with the same file
3719 if (!decc_filename_unix_only) {
3720 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3721 fp = fopen(file,"w");
3723 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3724 fp = fopen(file,"w");
3726 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3727 fp = fopen(file,"w");
3732 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3733 fp = fopen(file,"w");
3735 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3736 fp = fopen(file,"w");
3738 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3739 fp = fopen(file,"w");
3743 if (!fp) return 0; /* we're hosed */
3745 fprintf(fp,"$! 'f$verify(0)'\n");
3746 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3747 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3748 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3749 fprintf(fp,"$ perl_on = \"set noon\"\n");
3750 fprintf(fp,"$ perl_exit = \"exit\"\n");
3751 fprintf(fp,"$ perl_del = \"delete\"\n");
3752 fprintf(fp,"$ pif = \"if\"\n");
3753 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3754 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3755 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3756 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3757 fprintf(fp,"$! --- build command line to get max possible length\n");
3758 fprintf(fp,"$c=perl_popen_cmd0\n");
3759 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3760 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3761 fprintf(fp,"$x=perl_popen_cmd3\n");
3762 fprintf(fp,"$c=c+x\n");
3763 fprintf(fp,"$ perl_on\n");
3764 fprintf(fp,"$ 'c'\n");
3765 fprintf(fp,"$ perl_status = $STATUS\n");
3766 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3767 fprintf(fp,"$ perl_exit 'perl_status'\n");
3770 fgetname(fp, file, 1);
3771 fstat(fileno(fp), (struct stat *)&s0);
3774 if (decc_filename_unix_only)
3775 do_tounixspec(file, file, 0, NULL);
3776 fp = fopen(file,"r","shr=get");
3778 fstat(fileno(fp), (struct stat *)&s1);
3780 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3781 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3790 static int vms_is_syscommand_xterm(void)
3792 const static struct dsc$descriptor_s syscommand_dsc =
3793 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3795 const static struct dsc$descriptor_s decwdisplay_dsc =
3796 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3798 struct item_list_3 items[2];
3799 unsigned short dvi_iosb[4];
3800 unsigned long devchar;
3801 unsigned long devclass;
3804 /* Very simple check to guess if sys$command is a decterm? */
3805 /* First see if the DECW$DISPLAY: device exists */
3807 items[0].code = DVI$_DEVCHAR;
3808 items[0].bufadr = &devchar;
3809 items[0].retadr = NULL;
3813 status = sys$getdviw
3814 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3816 if ($VMS_STATUS_SUCCESS(status)) {
3817 status = dvi_iosb[0];
3820 if (!$VMS_STATUS_SUCCESS(status)) {
3821 SETERRNO(EVMSERR, status);
3825 /* If it does, then for now assume that we are on a workstation */
3826 /* Now verify that SYS$COMMAND is a terminal */
3827 /* for creating the debugger DECTerm */
3830 items[0].code = DVI$_DEVCLASS;
3831 items[0].bufadr = &devclass;
3832 items[0].retadr = NULL;
3836 status = sys$getdviw
3837 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3839 if ($VMS_STATUS_SUCCESS(status)) {
3840 status = dvi_iosb[0];
3843 if (!$VMS_STATUS_SUCCESS(status)) {
3844 SETERRNO(EVMSERR, status);
3848 if (devclass == DC$_TERM) {
3855 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3856 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3861 char device_name[65];
3862 unsigned short device_name_len;
3863 struct dsc$descriptor_s customization_dsc;
3864 struct dsc$descriptor_s device_name_dsc;
3867 char customization[200];
3871 unsigned short p_chan;
3873 unsigned short iosb[4];
3874 struct item_list_3 items[2];
3875 const char * cust_str =
3876 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3877 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3878 DSC$K_CLASS_S, mbx1};
3880 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3881 /*---------------------------------------*/
3882 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3885 /* Make sure that this is from the Perl debugger */
3886 ret_char = strstr(cmd," xterm ");
3887 if (ret_char == NULL)
3889 cptr = ret_char + 7;
3890 ret_char = strstr(cmd,"tty");
3891 if (ret_char == NULL)
3893 ret_char = strstr(cmd,"sleep");
3894 if (ret_char == NULL)
3897 if (decw_term_port == 0) {
3898 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3899 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3900 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3902 status = lib$find_image_symbol
3904 &decw_term_port_dsc,
3905 (void *)&decw_term_port,
3909 /* Try again with the other image name */
3910 if (!$VMS_STATUS_SUCCESS(status)) {
3912 status = lib$find_image_symbol
3914 &decw_term_port_dsc,
3915 (void *)&decw_term_port,
3924 /* No decw$term_port, give it up */
3925 if (!$VMS_STATUS_SUCCESS(status))
3928 /* Are we on a workstation? */
3929 /* to do: capture the rows / columns and pass their properties */
3930 ret_stat = vms_is_syscommand_xterm();
3934 /* Make the title: */
3935 ret_char = strstr(cptr,"-title");
3936 if (ret_char != NULL) {
3937 while ((*cptr != 0) && (*cptr != '\"')) {
3943 while ((*cptr != 0) && (*cptr != '\"')) {
3956 strcpy(title,"Perl Debug DECTerm");
3958 sprintf(customization, cust_str, title);
3960 customization_dsc.dsc$a_pointer = customization;
3961 customization_dsc.dsc$w_length = strlen(customization);
3962 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3963 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3965 device_name_dsc.dsc$a_pointer = device_name;
3966 device_name_dsc.dsc$w_length = sizeof device_name -1;
3967 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3968 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3970 device_name_len = 0;
3972 /* Try to create the window */
3973 status = (*decw_term_port)
3982 if (!$VMS_STATUS_SUCCESS(status)) {
3983 SETERRNO(EVMSERR, status);
3987 device_name[device_name_len] = '\0';
3989 /* Need to set this up to look like a pipe for cleanup */
3991 status = lib$get_vm(&n, &info);
3992 if (!$VMS_STATUS_SUCCESS(status)) {
3993 SETERRNO(ENOMEM, status);
3999 info->completion = 0;
4000 info->closing = FALSE;
4007 info->in_done = TRUE;
4008 info->out_done = TRUE;
4009 info->err_done = TRUE;
4011 /* Assign a channel on this so that it will persist, and not login */
4012 /* We stash this channel in the info structure for reference. */
4013 /* The created xterm self destructs when the last channel is removed */
4014 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4015 /* So leave this assigned. */
4016 device_name_dsc.dsc$w_length = device_name_len;
4017 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4018 if (!$VMS_STATUS_SUCCESS(status)) {
4019 SETERRNO(EVMSERR, status);
4022 info->xchan_valid = 1;
4024 /* Now create a mailbox to be read by the application */
4026 create_mbx(aTHX_ &p_chan, &d_mbx1);
4028 /* write the name of the created terminal to the mailbox */
4029 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4030 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4032 if (!$VMS_STATUS_SUCCESS(status)) {
4033 SETERRNO(EVMSERR, status);
4037 info->fp = PerlIO_open(mbx1, mode);
4039 /* Done with this channel */
4042 /* If any errors, then clean up */
4045 _ckvmssts(lib$free_vm(&n, &info));
4054 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4056 static int handler_set_up = FALSE;
4057 unsigned long int sts, flags = CLI$M_NOWAIT;
4058 /* The use of a GLOBAL table (as was done previously) rendered
4059 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4060 * environment. Hence we've switched to LOCAL symbol table.
4062 unsigned int table = LIB$K_CLI_LOCAL_SYM;
4064 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4065 char *in, *out, *err, mbx[512];
4067 char tfilebuf[NAM$C_MAXRSS+1];
4069 char cmd_sym_name[20];
4070 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4071 DSC$K_CLASS_S, symbol};
4072 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4074 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4075 DSC$K_CLASS_S, cmd_sym_name};
4076 struct dsc$descriptor_s *vmscmd;
4077 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4078 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4079 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4081 /* Check here for Xterm create request. This means looking for
4082 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4083 * is possible to create an xterm.
4085 if (*in_mode == 'r') {
4088 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4089 if (xterm_fd != Nullfp)
4093 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4095 /* once-per-program initialization...
4096 note that the SETAST calls and the dual test of pipe_ef
4097 makes sure that only the FIRST thread through here does
4098 the initialization...all other threads wait until it's
4101 Yeah, uglier than a pthread call, it's got all the stuff inline
4102 rather than in a separate routine.
4106 _ckvmssts(sys$setast(0));
4108 unsigned long int pidcode = JPI$_PID;
4109 $DESCRIPTOR(d_delay, RETRY_DELAY);
4110 _ckvmssts(lib$get_ef(&pipe_ef));
4111 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4112 _ckvmssts(sys$bintim(&d_delay, delaytime));
4114 if (!handler_set_up) {
4115 _ckvmssts(sys$dclexh(&pipe_exitblock));
4116 handler_set_up = TRUE;
4118 _ckvmssts(sys$setast(1));
4121 /* see if we can find a VMSPIPE.COM */
4124 vmspipe = find_vmspipe(aTHX);
4126 strcpy(tfilebuf+1,vmspipe);
4127 } else { /* uh, oh...we're in tempfile hell */
4128 tpipe = vmspipe_tempfile(aTHX);
4129 if (!tpipe) { /* a fish popular in Boston */
4130 if (ckWARN(WARN_PIPE)) {
4131 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4135 fgetname(tpipe,tfilebuf+1,1);
4137 vmspipedsc.dsc$a_pointer = tfilebuf;
4138 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4140 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4143 case RMS$_FNF: case RMS$_DNF:
4144 set_errno(ENOENT); break;
4146 set_errno(ENOTDIR); break;
4148 set_errno(ENODEV); break;
4150 set_errno(EACCES); break;
4152 set_errno(EINVAL); break;
4153 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4154 set_errno(E2BIG); break;
4155 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4156 _ckvmssts(sts); /* fall through */
4157 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4160 set_vaxc_errno(sts);
4161 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4162 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4168 _ckvmssts(lib$get_vm(&n, &info));
4170 strcpy(mode,in_mode);
4173 info->completion = 0;
4174 info->closing = FALSE;
4181 info->in_done = TRUE;
4182 info->out_done = TRUE;
4183 info->err_done = TRUE;
4185 info->xchan_valid = 0;
4187 in = PerlMem_malloc(VMS_MAXRSS);
4188 if (in == NULL) _ckvmssts(SS$_INSFMEM);
4189 out = PerlMem_malloc(VMS_MAXRSS);
4190 if (out == NULL) _ckvmssts(SS$_INSFMEM);
4191 err = PerlMem_malloc(VMS_MAXRSS);
4192 if (err == NULL) _ckvmssts(SS$_INSFMEM);
4194 in[0] = out[0] = err[0] = '\0';
4196 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4200 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4205 if (*mode == 'r') { /* piping from subroutine */
4207 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4209 info->out->pipe_done = &info->out_done;
4210 info->out_done = FALSE;
4211 info->out->info = info;
4213 if (!info->useFILE) {
4214 info->fp = PerlIO_open(mbx, mode);
4216 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4217 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4220 if (!info->fp && info->out) {
4221 sys$cancel(info->out->chan_out);
4223 while (!info->out_done) {
4225 _ckvmssts(sys$setast(0));
4226 done = info->out_done;
4227 if (!done) _ckvmssts(sys$clref(pipe_ef));
4228 _ckvmssts(sys$setast(1));
4229 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4232 if (info->out->buf) {
4233 n = info->out->bufsize * sizeof(char);
4234 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4237 _ckvmssts(lib$free_vm(&n, &info->out));
4239 _ckvmssts(lib$free_vm(&n, &info));
4244 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4246 info->err->pipe_done = &info->err_done;
4247 info->err_done = FALSE;
4248 info->err->info = info;
4251 } else if (*mode == 'w') { /* piping to subroutine */
4253 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4255 info->out->pipe_done = &info->out_done;
4256 info->out_done = FALSE;
4257 info->out->info = info;
4260 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4262 info->err->pipe_done = &info->err_done;
4263 info->err_done = FALSE;
4264 info->err->info = info;
4267 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4268 if (!info->useFILE) {
4269 info->fp = PerlIO_open(mbx, mode);
4271 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4272 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4276 info->in->pipe_done = &info->in_done;
4277 info->in_done = FALSE;
4278 info->in->info = info;
4282 if (!info->fp && info->in) {
4284 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4285 0, 0, 0, 0, 0, 0, 0, 0));
4287 while (!info->in_done) {
4289 _ckvmssts(sys$setast(0));
4290 done = info->in_done;
4291 if (!done) _ckvmssts(sys$clref(pipe_ef));
4292 _ckvmssts(sys$setast(1));
4293 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4296 if (info->in->buf) {
4297 n = info->in->bufsize * sizeof(char);
4298 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4301 _ckvmssts(lib$free_vm(&n, &info->in));
4303 _ckvmssts(lib$free_vm(&n, &info));
4309 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4310 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4312 info->out->pipe_done = &info->out_done;
4313 info->out_done = FALSE;
4314 info->out->info = info;
4317 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4319 info->err->pipe_done = &info->err_done;
4320 info->err_done = FALSE;
4321 info->err->info = info;
4325 symbol[MAX_DCL_SYMBOL] = '\0';
4327 strncpy(symbol, in, MAX_DCL_SYMBOL);
4328 d_symbol.dsc$w_length = strlen(symbol);
4329 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4331 strncpy(symbol, err, MAX_DCL_SYMBOL);
4332 d_symbol.dsc$w_length = strlen(symbol);
4333 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4335 strncpy(symbol, out, MAX_DCL_SYMBOL);
4336 d_symbol.dsc$w_length = strlen(symbol);
4337 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4339 /* Done with the names for the pipes */
4344 p = vmscmd->dsc$a_pointer;
4345 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4346 if (*p == '$') p++; /* remove leading $ */
4347 while (*p == ' ' || *p == '\t') p++;
4349 for (j = 0; j < 4; j++) {
4350 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4351 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4353 strncpy(symbol, p, MAX_DCL_SYMBOL);
4354 d_symbol.dsc$w_length = strlen(symbol);
4355 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4357 if (strlen(p) > MAX_DCL_SYMBOL) {
4358 p += MAX_DCL_SYMBOL;
4363 _ckvmssts(sys$setast(0));
4364 info->next=open_pipes; /* prepend to list */
4366 _ckvmssts(sys$setast(1));
4367 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4368 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4369 * have SYS$COMMAND if we need it.
4371 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4372 0, &info->pid, &info->completion,
4373 0, popen_completion_ast,info,0,0,0));
4375 /* if we were using a tempfile, close it now */
4377 if (tpipe) fclose(tpipe);
4379 /* once the subprocess is spawned, it has copied the symbols and
4380 we can get rid of ours */
4382 for (j = 0; j < 4; j++) {
4383 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4384 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4385 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4387 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4388 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4389 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4390 vms_execfree(vmscmd);
4392 #ifdef PERL_IMPLICIT_CONTEXT
4395 PL_forkprocess = info->pid;
4400 _ckvmssts(sys$setast(0));
4402 if (!done) _ckvmssts(sys$clref(pipe_ef));
4403 _ckvmssts(sys$setast(1));
4404 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4406 *psts = info->completion;
4407 /* Caller thinks it is open and tries to close it. */
4408 /* This causes some problems, as it changes the error status */
4409 /* my_pclose(info->fp); */
4414 } /* end of safe_popen */
4417 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4419 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4423 TAINT_PROPER("popen");
4424 PERL_FLUSHALL_FOR_CHILD;
4425 return safe_popen(aTHX_ cmd,mode,&sts);
4430 /*{{{ I32 my_pclose(PerlIO *fp)*/
4431 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4433 pInfo info, last = NULL;
4434 unsigned long int retsts;
4438 for (info = open_pipes; info != NULL; last = info, info = info->next)
4439 if (info->fp == fp) break;
4441 if (info == NULL) { /* no such pipe open */
4442 set_errno(ECHILD); /* quoth POSIX */
4443 set_vaxc_errno(SS$_NONEXPR);
4447 /* If we were writing to a subprocess, insure that someone reading from
4448 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4449 * produce an EOF record in the mailbox.
4451 * well, at least sometimes it *does*, so we have to watch out for
4452 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4456 #if defined(USE_ITHREADS)
4459 && PL_perlio_fd_refcnt)
4460 PerlIO_flush(info->fp);
4462 fflush((FILE *)info->fp);
4465 _ckvmssts(sys$setast(0));
4466 info->closing = TRUE;
4467 done = info->done && info->in_done && info->out_done && info->err_done;
4468 /* hanging on write to Perl's input? cancel it */
4469 if (info->mode == 'r' && info->out && !info->out_done) {
4470 if (info->out->chan_out) {
4471 _ckvmssts(sys$cancel(info->out->chan_out));
4472 if (!info->out->chan_in) { /* EOF generation, need AST */
4473 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4477 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4478 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4480 _ckvmssts(sys$setast(1));
4483 #if defined(USE_ITHREADS)
4486 && PL_perlio_fd_refcnt)
4487 PerlIO_close(info->fp);
4489 fclose((FILE *)info->fp);
4492 we have to wait until subprocess completes, but ALSO wait until all
4493 the i/o completes...otherwise we'll be freeing the "info" structure
4494 that the i/o ASTs could still be using...
4498 _ckvmssts(sys$setast(0));
4499 done = info->done && info->in_done && info->out_done && info->err_done;
4500 if (!done) _ckvmssts(sys$clref(pipe_ef));
4501 _ckvmssts(sys$setast(1));
4502 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4504 retsts = info->completion;
4506 /* remove from list of open pipes */
4507 _ckvmssts(sys$setast(0));
4508 if (last) last->next = info->next;
4509 else open_pipes = info->next;
4510 _ckvmssts(sys$setast(1));
4512 /* free buffers and structures */
4515 if (info->in->buf) {
4516 n = info->in->bufsize * sizeof(char);
4517 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4520 _ckvmssts(lib$free_vm(&n, &info->in));
4523 if (info->out->buf) {
4524 n = info->out->bufsize * sizeof(char);
4525 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4528 _ckvmssts(lib$free_vm(&n, &info->out));
4531 if (info->err->buf) {
4532 n = info->err->bufsize * sizeof(char);
4533 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4536 _ckvmssts(lib$free_vm(&n, &info->err));
4539 _ckvmssts(lib$free_vm(&n, &info));
4543 } /* end of my_pclose() */
4545 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4546 /* Roll our own prototype because we want this regardless of whether
4547 * _VMS_WAIT is defined.
4549 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4551 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4552 created with popen(); otherwise partially emulate waitpid() unless
4553 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4554 Also check processes not considered by the CRTL waitpid().
4556 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4558 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4565 if (statusp) *statusp = 0;
4567 for (info = open_pipes; info != NULL; info = info->next)
4568 if (info->pid == pid) break;
4570 if (info != NULL) { /* we know about this child */
4571 while (!info->done) {
4572 _ckvmssts(sys$setast(0));
4574 if (!done) _ckvmssts(sys$clref(pipe_ef));
4575 _ckvmssts(sys$setast(1));
4576 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4579 if (statusp) *statusp = info->completion;
4583 /* child that already terminated? */
4585 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4586 if (closed_list[j].pid == pid) {
4587 if (statusp) *statusp = closed_list[j].completion;
4592 /* fall through if this child is not one of our own pipe children */
4594 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4596 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4597 * in 7.2 did we get a version that fills in the VMS completion
4598 * status as Perl has always tried to do.
4601 sts = __vms_waitpid( pid, statusp, flags );
4603 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4606 /* If the real waitpid tells us the child does not exist, we
4607 * fall through here to implement waiting for a child that
4608 * was created by some means other than exec() (say, spawned
4609 * from DCL) or to wait for a process that is not a subprocess
4610 * of the current process.
4613 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4616 $DESCRIPTOR(intdsc,"0 00:00:01");
4617 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4618 unsigned long int pidcode = JPI$_PID, mypid;
4619 unsigned long int interval[2];
4620 unsigned int jpi_iosb[2];
4621 struct itmlst_3 jpilist[2] = {
4622 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4627 /* Sorry folks, we don't presently implement rooting around for
4628 the first child we can find, and we definitely don't want to
4629 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4635 /* Get the owner of the child so I can warn if it's not mine. If the
4636 * process doesn't exist or I don't have the privs to look at it,
4637 * I can go home early.
4639 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4640 if (sts & 1) sts = jpi_iosb[0];
4652 set_vaxc_errno(sts);
4656 if (ckWARN(WARN_EXEC)) {
4657 /* remind folks they are asking for non-standard waitpid behavior */
4658 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4659 if (ownerpid != mypid)
4660 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4661 "waitpid: process %x is not a child of process %x",
4665 /* simply check on it once a second until it's not there anymore. */
4667 _ckvmssts(sys$bintim(&intdsc,interval));
4668 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4669 _ckvmssts(sys$schdwk(0,0,interval,0));
4670 _ckvmssts(sys$hiber());
4672 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4677 } /* end of waitpid() */
4682 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4684 my_gconvert(double val, int ndig, int trail, char *buf)
4686 static char __gcvtbuf[DBL_DIG+1];
4689 loc = buf ? buf : __gcvtbuf;
4691 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4693 sprintf(loc,"%.*g",ndig,val);
4699 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4700 return gcvt(val,ndig,loc);
4703 loc[0] = '0'; loc[1] = '\0';
4710 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4711 static int rms_free_search_context(struct FAB * fab)
4715 nam = fab->fab$l_nam;
4716 nam->nam$b_nop |= NAM$M_SYNCHK;
4717 nam->nam$l_rlf = NULL;
4719 return sys$parse(fab, NULL, NULL);
4722 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4723 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4724 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4725 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4726 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4727 #define rms_nam_esll(nam) nam.nam$b_esl
4728 #define rms_nam_esl(nam) nam.nam$b_esl
4729 #define rms_nam_name(nam) nam.nam$l_name
4730 #define rms_nam_namel(nam) nam.nam$l_name
4731 #define rms_nam_type(nam) nam.nam$l_type
4732 #define rms_nam_typel(nam) nam.nam$l_type
4733 #define rms_nam_ver(nam) nam.nam$l_ver
4734 #define rms_nam_verl(nam) nam.nam$l_ver
4735 #define rms_nam_rsll(nam) nam.nam$b_rsl
4736 #define rms_nam_rsl(nam) nam.nam$b_rsl
4737 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4738 #define rms_set_fna(fab, nam, name, size) \
4739 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4740 #define rms_get_fna(fab, nam) fab.fab$l_fna
4741 #define rms_set_dna(fab, nam, name, size) \
4742 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4743 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4744 #define rms_set_esa(fab, nam, name, size) \
4745 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4746 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4747 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4748 #define rms_set_rsa(nam, name, size) \
4749 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4750 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4751 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4752 #define rms_nam_name_type_l_size(nam) \
4753 (nam.nam$b_name + nam.nam$b_type)
4755 static int rms_free_search_context(struct FAB * fab)
4759 nam = fab->fab$l_naml;
4760 nam->naml$b_nop |= NAM$M_SYNCHK;
4761 nam->naml$l_rlf = NULL;
4762 nam->naml$l_long_defname_size = 0;
4765 return sys$parse(fab, NULL, NULL);
4768 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4769 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4770 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4771 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4772 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4773 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4774 #define rms_nam_esl(nam) nam.naml$b_esl
4775 #define rms_nam_name(nam) nam.naml$l_name
4776 #define rms_nam_namel(nam) nam.naml$l_long_name
4777 #define rms_nam_type(nam) nam.naml$l_type
4778 #define rms_nam_typel(nam) nam.naml$l_long_type
4779 #define rms_nam_ver(nam) nam.naml$l_ver
4780 #define rms_nam_verl(nam) nam.naml$l_long_ver
4781 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4782 #define rms_nam_rsl(nam) nam.naml$b_rsl
4783 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4784 #define rms_set_fna(fab, nam, name, size) \
4785 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4786 nam.naml$l_long_filename_size = size; \
4787 nam.naml$l_long_filename = name;}
4788 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4789 #define rms_set_dna(fab, nam, name, size) \
4790 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4791 nam.naml$l_long_defname_size = size; \
4792 nam.naml$l_long_defname = name; }
4793 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4794 #define rms_set_esa(fab, nam, name, size) \
4795 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4796 nam.naml$l_long_expand_alloc = size; \
4797 nam.naml$l_long_expand = name; }
4798 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4799 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4800 nam.naml$l_long_expand = l_name; \
4801 nam.naml$l_long_expand_alloc = l_size; }
4802 #define rms_set_rsa(nam, name, size) \
4803 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4804 nam.naml$l_long_result = name; \
4805 nam.naml$l_long_result_alloc = size; }
4806 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4807 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4808 nam.naml$l_long_result = l_name; \
4809 nam.naml$l_long_result_alloc = l_size; }
4810 #define rms_nam_name_type_l_size(nam) \
4811 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4816 * The CRTL for 8.3 and later can create symbolic links in any mode,
4817 * however in 8.3 the unlink/remove/delete routines will only properly handle
4818 * them if one of the PCP modes is active.
4820 static int rms_erase(const char * vmsname)
4823 struct FAB myfab = cc$rms_fab;
4824 rms_setup_nam(mynam);
4826 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4827 rms_bind_fab_nam(myfab, mynam);
4829 /* Are we removing all versions? */
4830 if (vms_unlink_all_versions == 1) {
4831 const char * defspec = ";*";
4832 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4835 #ifdef NAML$M_OPEN_SPECIAL
4836 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4839 status = sys$erase(&myfab, 0, 0);
4846 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4847 const struct dsc$descriptor_s * vms_dst_dsc,
4848 unsigned long flags)
4850 /* VMS and UNIX handle file permissions differently and the
4851 * the same ACL trick may be needed for renaming files,
4852 * especially if they are directories.
4855 /* todo: get kill_file and rename to share common code */
4856 /* I can not find online documentation for $change_acl
4857 * it appears to be replaced by $set_security some time ago */
4859 const unsigned int access_mode = 0;
4860 $DESCRIPTOR(obj_file_dsc,"FILE");
4863 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4864 int aclsts, fndsts, rnsts = -1;
4865 unsigned int ctx = 0;
4866 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4867 struct dsc$descriptor_s * clean_dsc;
4870 unsigned char myace$b_length;
4871 unsigned char myace$b_type;
4872 unsigned short int myace$w_flags;
4873 unsigned long int myace$l_access;
4874 unsigned long int myace$l_ident;
4875 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4876 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4878 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4881 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4882 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4884 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4885 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4889 /* Expand the input spec using RMS, since we do not want to put
4890 * ACLs on the target of a symbolic link */
4891 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4892 if (vmsname == NULL)
4895 rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
4899 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
4903 PerlMem_free(vmsname);
4907 /* So we get our own UIC to use as a rights identifier,
4908 * and the insert an ACE at the head of the ACL which allows us
4909 * to delete the file.
4911 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4913 fildsc.dsc$w_length = strlen(vmsname);
4914 fildsc.dsc$a_pointer = vmsname;
4916 newace.myace$l_ident = oldace.myace$l_ident;
4919 /* Grab any existing ACEs with this identifier in case we fail */
4920 clean_dsc = &fildsc;
4921 aclsts = fndsts = sys$get_security(&obj_file_dsc,
4929 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
4930 /* Add the new ACE . . . */
4932 /* if the sys$get_security succeeded, then ctx is valid, and the
4933 * object/file descriptors will be ignored. But otherwise they
4936 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4937 OSS$M_RELCTX, addlst, &ctx, &access_mode);
4938 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4940 set_vaxc_errno(aclsts);
4941 PerlMem_free(vmsname);
4945 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4948 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4950 if ($VMS_STATUS_SUCCESS(rnsts)) {
4951 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4954 /* Put things back the way they were. */
4956 aclsts = sys$get_security(&obj_file_dsc,
4964 if ($VMS_STATUS_SUCCESS(aclsts)) {
4968 if (!$VMS_STATUS_SUCCESS(fndsts))
4969 sec_flags = OSS$M_RELCTX;
4971 /* Get rid of the new ACE */
4972 aclsts = sys$set_security(NULL, NULL, NULL,
4973 sec_flags, dellst, &ctx, &access_mode);
4975 /* If there was an old ACE, put it back */
4976 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
4977 addlst[0].bufadr = &oldace;
4978 aclsts = sys$set_security(NULL, NULL, NULL,
4979 OSS$M_RELCTX, addlst, &ctx, &access_mode);
4980 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4982 set_vaxc_errno(aclsts);
4988 /* Try to clear the lock on the ACL list */
4989 aclsts2 = sys$set_security(NULL, NULL, NULL,
4990 OSS$M_RELCTX, NULL, &ctx, &access_mode);
4992 /* Rename errors are most important */
4993 if (!$VMS_STATUS_SUCCESS(rnsts))
4996 set_vaxc_errno(aclsts);
5001 if (aclsts != SS$_ACLEMPTY)
5008 PerlMem_free(vmsname);
5013 /*{{{int rename(const char *, const char * */
5014 /* Not exactly what X/Open says to do, but doing it absolutely right
5015 * and efficiently would require a lot more work. This should be close
5016 * enough to pass all but the most strict X/Open compliance test.
5019 Perl_rename(pTHX_ const char *src, const char * dst)
5028 /* Validate the source file */
5029 src_sts = flex_lstat(src, &src_st);
5032 /* No source file or other problem */
5036 dst_sts = flex_lstat(dst, &dst_st);
5039 if (dst_st.st_dev != src_st.st_dev) {
5040 /* Must be on the same device */
5045 /* VMS_INO_T_COMPARE is true if the inodes are different
5046 * to match the output of memcmp
5049 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5050 /* That was easy, the files are the same! */
5054 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5055 /* If source is a directory, so must be dest */
5063 if ((dst_sts == 0) &&
5064 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5066 /* We have issues here if vms_unlink_all_versions is set
5067 * If the destination exists, and is not a directory, then
5068 * we must delete in advance.
5070 * If the src is a directory, then we must always pre-delete
5073 * If we successfully delete the dst in advance, and the rename fails
5074 * X/Open requires that errno be EIO.
5078 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5080 d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5084 /* We killed the destination, so only errno now is EIO */
5089 /* Originally the idea was to call the CRTL rename() and only
5090 * try the lib$rename_file if it failed.
5091 * It turns out that there are too many variants in what the
5092 * the CRTL rename might do, so only use lib$rename_file
5097 /* Is the source and dest both in VMS format */
5098 /* if the source is a directory, then need to fileify */
5099 /* and dest must be a directory or non-existant. */
5105 unsigned long flags;
5106 struct dsc$descriptor_s old_file_dsc;
5107 struct dsc$descriptor_s new_file_dsc;
5109 /* We need to modify the src and dst depending
5110 * on if one or more of them are directories.
5113 vms_src = PerlMem_malloc(VMS_MAXRSS);
5114 if (vms_src == NULL)
5115 _ckvmssts(SS$_INSFMEM);
5117 /* Source is always a VMS format file */
5118 ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5119 if (ret_str == NULL) {
5120 PerlMem_free(vms_src);
5125 vms_dst = PerlMem_malloc(VMS_MAXRSS);
5126 if (vms_dst == NULL)
5127 _ckvmssts(SS$_INSFMEM);
5129 if (S_ISDIR(src_st.st_mode)) {
5131 char * vms_dir_file;
5133 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5134 if (vms_dir_file == NULL)
5135 _ckvmssts(SS$_INSFMEM);
5137 /* The source must be a file specification */
5138 ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5139 if (ret_str == NULL) {
5140 PerlMem_free(vms_src);
5141 PerlMem_free(vms_dst);
5142 PerlMem_free(vms_dir_file);
5146 PerlMem_free(vms_src);
5147 vms_src = vms_dir_file;
5149 /* If the dest is a directory, we must remove it
5152 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5154 PerlMem_free(vms_src);
5155 PerlMem_free(vms_dst);
5163 /* The dest must be a VMS file specification */
5164 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5165 if (ret_str == NULL) {
5166 PerlMem_free(vms_src);
5167 PerlMem_free(vms_dst);
5172 /* The source must be a file specification */
5173 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5174 if (vms_dir_file == NULL)
5175 _ckvmssts(SS$_INSFMEM);
5177 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5178 if (ret_str == NULL) {
5179 PerlMem_free(vms_src);
5180 PerlMem_free(vms_dst);
5181 PerlMem_free(vms_dir_file);
5185 PerlMem_free(vms_dst);
5186 vms_dst = vms_dir_file;
5189 /* File to file or file to new dir */
5191 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5192 /* VMS pathify a dir target */
5193 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5194 if (ret_str == NULL) {
5195 PerlMem_free(vms_src);
5196 PerlMem_free(vms_dst);
5202 /* fileify a target VMS file specification */
5203 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5204 if (ret_str == NULL) {
5205 PerlMem_free(vms_src);
5206 PerlMem_free(vms_dst);
5213 old_file_dsc.dsc$a_pointer = vms_src;
5214 old_file_dsc.dsc$w_length = strlen(vms_src);
5215 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5216 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5218 new_file_dsc.dsc$a_pointer = vms_dst;
5219 new_file_dsc.dsc$w_length = strlen(vms_dst);
5220 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5221 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5224 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5225 flags |= 2; /* LIB$M_FIL_LONG_NAMES */
5228 sts = lib$rename_file(&old_file_dsc,
5232 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5233 if (!$VMS_STATUS_SUCCESS(sts)) {
5235 /* We could have failed because VMS style permissions do not
5236 * permit renames that UNIX will allow. Just like the hack
5239 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5242 PerlMem_free(vms_src);
5243 PerlMem_free(vms_dst);
5244 if (!$VMS_STATUS_SUCCESS(sts)) {
5251 if (vms_unlink_all_versions) {
5252 /* Now get rid of any previous versions of the source file that
5257 src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5261 /* We deleted the destination, so must force the error to be EIO */
5262 if ((retval != 0) && (pre_delete != 0))
5270 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5271 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5272 * to expand file specification. Allows for a single default file
5273 * specification and a simple mask of options. If outbuf is non-NULL,
5274 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5275 * the resultant file specification is placed. If outbuf is NULL, the
5276 * resultant file specification is placed into a static buffer.
5277 * The third argument, if non-NULL, is taken to be a default file
5278 * specification string. The fourth argument is unused at present.
5279 * rmesexpand() returns the address of the resultant string if
5280 * successful, and NULL on error.
5282 * New functionality for previously unused opts value:
5283 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5284 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5285 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5286 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5288 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5292 (pTHX_ const char *filespec,
5295 const char *defspec,
5300 static char __rmsexpand_retbuf[VMS_MAXRSS];
5301 char * vmsfspec, *tmpfspec;
5302 char * esa, *cp, *out = NULL;
5306 struct FAB myfab = cc$rms_fab;
5307 rms_setup_nam(mynam);
5309 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5312 /* temp hack until UTF8 is actually implemented */
5313 if (fs_utf8 != NULL)
5316 if (!filespec || !*filespec) {
5317 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5321 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5322 else outbuf = __rmsexpand_retbuf;
5330 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5331 isunix = is_unix_filespec(filespec);
5333 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5334 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
5335 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
5336 PerlMem_free(vmsfspec);
5341 filespec = vmsfspec;
5343 /* Unless we are forcing to VMS format, a UNIX input means
5344 * UNIX output, and that requires long names to be used
5346 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5347 opts |= PERL_RMSEXPAND_M_LONG;
5354 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5355 rms_bind_fab_nam(myfab, mynam);
5357 if (defspec && *defspec) {
5359 t_isunix = is_unix_filespec(defspec);
5361 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5362 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5363 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
5364 PerlMem_free(tmpfspec);
5365 if (vmsfspec != NULL)
5366 PerlMem_free(vmsfspec);
5373 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5376 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5377 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5378 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5379 esal = PerlMem_malloc(VMS_MAXRSS);
5380 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5382 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5384 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5385 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
5388 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5389 outbufl = PerlMem_malloc(VMS_MAXRSS);
5390 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
5391 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5393 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
5397 #ifdef NAM$M_NO_SHORT_UPCASE
5398 if (decc_efs_case_preserve)
5399 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5402 /* We may not want to follow symbolic links */
5403 #ifdef NAML$M_OPEN_SPECIAL
5404 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5405 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5408 /* First attempt to parse as an existing file */
5409 retsts = sys$parse(&myfab,0,0);
5410 if (!(retsts & STS$K_SUCCESS)) {
5412 /* Could not find the file, try as syntax only if error is not fatal */
5413 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5414 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5415 retsts = sys$parse(&myfab,0,0);
5416 if (retsts & STS$K_SUCCESS) goto expanded;
5419 /* Still could not parse the file specification */
5420 /*----------------------------------------------*/
5421 sts = rms_free_search_context(&myfab); /* Free search context */
5422 if (out) Safefree(out);
5423 if (tmpfspec != NULL)
5424 PerlMem_free(tmpfspec);
5425 if (vmsfspec != NULL)
5426 PerlMem_free(vmsfspec);
5427 if (outbufl != NULL)
5428 PerlMem_free(outbufl);
5432 set_vaxc_errno(retsts);
5433 if (retsts == RMS$_PRV) set_errno(EACCES);
5434 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5435 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5436 else set_errno(EVMSERR);
5439 retsts = sys$search(&myfab,0,0);
5440 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5441 sts = rms_free_search_context(&myfab); /* Free search context */
5442 if (out) Safefree(out);
5443 if (tmpfspec != NULL)
5444 PerlMem_free(tmpfspec);
5445 if (vmsfspec != NULL)
5446 PerlMem_free(vmsfspec);
5447 if (outbufl != NULL)
5448 PerlMem_free(outbufl);
5452 set_vaxc_errno(retsts);
5453 if (retsts == RMS$_PRV) set_errno(EACCES);
5454 else set_errno(EVMSERR);
5458 /* If the input filespec contained any lowercase characters,
5459 * downcase the result for compatibility with Unix-minded code. */
5461 if (!decc_efs_case_preserve) {
5462 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5463 if (islower(*tbuf)) { haslower = 1; break; }
5466 /* Is a long or a short name expected */
5467 /*------------------------------------*/
5468 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5469 if (rms_nam_rsll(mynam)) {
5471 speclen = rms_nam_rsll(mynam);
5474 tbuf = esal; /* Not esa */
5475 speclen = rms_nam_esll(mynam);
5479 if (rms_nam_rsl(mynam)) {
5481 speclen = rms_nam_rsl(mynam);
5484 tbuf = esa; /* Not esal */
5485 speclen = rms_nam_esl(mynam);
5488 tbuf[speclen] = '\0';
5490 /* Trim off null fields added by $PARSE
5491 * If type > 1 char, must have been specified in original or default spec
5492 * (not true for version; $SEARCH may have added version of existing file).
5494 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5495 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5496 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5497 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5500 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5501 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5503 if (trimver || trimtype) {
5504 if (defspec && *defspec) {
5505 char *defesal = NULL;
5506 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5507 if (defesal != NULL) {
5508 struct FAB deffab = cc$rms_fab;
5509 rms_setup_nam(defnam);
5511 rms_bind_fab_nam(deffab, defnam);
5515 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5517 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
5519 rms_clear_nam_nop(defnam);
5520 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5521 #ifdef NAM$M_NO_SHORT_UPCASE
5522 if (decc_efs_case_preserve)
5523 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5525 #ifdef NAML$M_OPEN_SPECIAL
5526 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5527 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5529 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5531 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5534 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5537 PerlMem_free(defesal);
5541 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5542 if (*(rms_nam_verl(mynam)) != '\"')
5543 speclen = rms_nam_verl(mynam) - tbuf;
5546 if (*(rms_nam_ver(mynam)) != '\"')
5547 speclen = rms_nam_ver(mynam) - tbuf;
5551 /* If we didn't already trim version, copy down */
5552 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5553 if (speclen > rms_nam_verl(mynam) - tbuf)
5555 (rms_nam_typel(mynam),
5556 rms_nam_verl(mynam),
5557 speclen - (rms_nam_verl(mynam) - tbuf));
5558 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5561 if (speclen > rms_nam_ver(mynam) - tbuf)
5563 (rms_nam_type(mynam),
5565 speclen - (rms_nam_ver(mynam) - tbuf));
5566 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5571 /* Done with these copies of the input files */
5572 /*-------------------------------------------*/
5573 if (vmsfspec != NULL)
5574 PerlMem_free(vmsfspec);
5575 if (tmpfspec != NULL)
5576 PerlMem_free(tmpfspec);
5578 /* If we just had a directory spec on input, $PARSE "helpfully"
5579 * adds an empty name and type for us */
5580 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5581 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5582 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5583 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5584 speclen = rms_nam_namel(mynam) - tbuf;
5587 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5588 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5589 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5590 speclen = rms_nam_name(mynam) - tbuf;
5593 /* Posix format specifications must have matching quotes */
5594 if (speclen < (VMS_MAXRSS - 1)) {
5595 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5596 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5597 tbuf[speclen] = '\"';
5602 tbuf[speclen] = '\0';
5603 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5605 /* Have we been working with an expanded, but not resultant, spec? */
5606 /* Also, convert back to Unix syntax if necessary. */
5608 if (!rms_nam_rsll(mynam)) {
5610 if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5611 if (out) Safefree(out);
5615 if (outbufl != NULL)
5616 PerlMem_free(outbufl);
5620 else strcpy(outbuf, tbuf);
5623 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5624 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5625 if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5626 if (out) Safefree(out);
5630 PerlMem_free(tmpfspec);
5631 if (outbufl != NULL)
5632 PerlMem_free(outbufl);
5635 strcpy(outbuf,tmpfspec);
5636 PerlMem_free(tmpfspec);
5639 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5640 sts = rms_free_search_context(&myfab); /* Free search context */
5644 if (outbufl != NULL)
5645 PerlMem_free(outbufl);
5649 /* External entry points */
5650 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5651 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5652 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5653 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5654 char *Perl_rmsexpand_utf8
5655 (pTHX_ const char *spec, char *buf, const char *def,
5656 unsigned opt, int * fs_utf8, int * dfs_utf8)
5657 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5658 char *Perl_rmsexpand_utf8_ts
5659 (pTHX_ const char *spec, char *buf, const char *def,
5660 unsigned opt, int * fs_utf8, int * dfs_utf8)
5661 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5665 ** The following routines are provided to make life easier when
5666 ** converting among VMS-style and Unix-style directory specifications.
5667 ** All will take input specifications in either VMS or Unix syntax. On
5668 ** failure, all return NULL. If successful, the routines listed below
5669 ** return a pointer to a buffer containing the appropriately
5670 ** reformatted spec (and, therefore, subsequent calls to that routine
5671 ** will clobber the result), while the routines of the same names with
5672 ** a _ts suffix appended will return a pointer to a mallocd string
5673 ** containing the appropriately reformatted spec.
5674 ** In all cases, only explicit syntax is altered; no check is made that
5675 ** the resulting string is valid or that the directory in question
5678 ** fileify_dirspec() - convert a directory spec into the name of the
5679 ** directory file (i.e. what you can stat() to see if it's a dir).
5680 ** The style (VMS or Unix) of the result is the same as the style
5681 ** of the parameter passed in.
5682 ** pathify_dirspec() - convert a directory spec into a path (i.e.
5683 ** what you prepend to a filename to indicate what directory it's in).
5684 ** The style (VMS or Unix) of the result is the same as the style
5685 ** of the parameter passed in.
5686 ** tounixpath() - convert a directory spec into a Unix-style path.
5687 ** tovmspath() - convert a directory spec into a VMS-style path.
5688 ** tounixspec() - convert any file spec into a Unix-style file spec.
5689 ** tovmsspec() - convert any file spec into a VMS-style spec.
5690 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5692 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
5693 ** Permission is given to distribute this code as part of the Perl
5694 ** standard distribution under the terms of the GNU General Public
5695 ** License or the Perl Artistic License. Copies of each may be
5696 ** found in the Perl standard distribution.
5699 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5700 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5702 static char __fileify_retbuf[VMS_MAXRSS];
5703 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5704 char *retspec, *cp1, *cp2, *lastdir;
5705 char *trndir, *vmsdir;
5706 unsigned short int trnlnm_iter_count;
5708 if (utf8_fl != NULL)
5711 if (!dir || !*dir) {
5712 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5714 dirlen = strlen(dir);
5715 while (dirlen && dir[dirlen-1] == '/') --dirlen;
5716 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5717 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5724 if (dirlen > (VMS_MAXRSS - 1)) {
5725 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5728 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5729 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5730 if (!strpbrk(dir+1,"/]>:") &&
5731 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5732 strcpy(trndir,*dir == '/' ? dir + 1: dir);
5733 trnlnm_iter_count = 0;
5734 while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5735 trnlnm_iter_count++;
5736 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5738 dirlen = strlen(trndir);
5741 strncpy(trndir,dir,dirlen);
5742 trndir[dirlen] = '\0';
5745 /* At this point we are done with *dir and use *trndir which is a
5746 * copy that can be modified. *dir must not be modified.
5749 /* If we were handed a rooted logical name or spec, treat it like a
5750 * simple directory, so that
5751 * $ Define myroot dev:[dir.]
5752 * ... do_fileify_dirspec("myroot",buf,1) ...
5753 * does something useful.
5755 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5756 trndir[--dirlen] = '\0';
5757 trndir[dirlen-1] = ']';
5759 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5760 trndir[--dirlen] = '\0';
5761 trndir[dirlen-1] = '>';
5764 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5765 /* If we've got an explicit filename, we can just shuffle the string. */
5766 if (*(cp1+1)) hasfilename = 1;
5767 /* Similarly, we can just back up a level if we've got multiple levels
5768 of explicit directories in a VMS spec which ends with directories. */
5770 for (cp2 = cp1; cp2 > trndir; cp2--) {
5772 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5773 /* fix-me, can not scan EFS file specs backward like this */
5774 *cp2 = *cp1; *cp1 = '\0';
5779 if (*cp2 == '[' || *cp2 == '<') break;
5784 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5785 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5786 cp1 = strpbrk(trndir,"]:>");
5787 if (hasfilename || !cp1) { /* Unix-style path or filename */
5788 if (trndir[0] == '.') {
5789 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5790 PerlMem_free(trndir);
5791 PerlMem_free(vmsdir);
5792 return do_fileify_dirspec("[]",buf,ts,NULL);
5794 else if (trndir[1] == '.' &&
5795 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5796 PerlMem_free(trndir);
5797 PerlMem_free(vmsdir);
5798 return do_fileify_dirspec("[-]",buf,ts,NULL);
5801 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
5802 dirlen -= 1; /* to last element */
5803 lastdir = strrchr(trndir,'/');
5805 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5806 /* If we have "/." or "/..", VMSify it and let the VMS code
5807 * below expand it, rather than repeating the code to handle
5808 * relative components of a filespec here */
5810 if (*(cp1+2) == '.') cp1++;
5811 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5813 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5814 PerlMem_free(trndir);
5815 PerlMem_free(vmsdir);
5818 if (strchr(vmsdir,'/') != NULL) {
5819 /* If do_tovmsspec() returned it, it must have VMS syntax
5820 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5821 * the time to check this here only so we avoid a recursion
5822 * loop; otherwise, gigo.
5824 PerlMem_free(trndir);
5825 PerlMem_free(vmsdir);
5826 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5829 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5830 PerlMem_free(trndir);
5831 PerlMem_free(vmsdir);
5834 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5835 PerlMem_free(trndir);
5836 PerlMem_free(vmsdir);
5840 } while ((cp1 = strstr(cp1,"/.")) != NULL);
5841 lastdir = strrchr(trndir,'/');
5843 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5845 /* Ditto for specs that end in an MFD -- let the VMS code
5846 * figure out whether it's a real device or a rooted logical. */
5848 /* This should not happen any more. Allowing the fake /000000
5849 * in a UNIX pathname causes all sorts of problems when trying
5850 * to run in UNIX emulation. So the VMS to UNIX conversions
5851 * now remove the fake /000000 directories.
5854 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5855 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5856 PerlMem_free(trndir);
5857 PerlMem_free(vmsdir);
5860 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5861 PerlMem_free(trndir);
5862 PerlMem_free(vmsdir);
5865 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5866 PerlMem_free(trndir);
5867 PerlMem_free(vmsdir);
5872 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5873 !(lastdir = cp1 = strrchr(trndir,']')) &&
5874 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5875 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
5878 /* For EFS or ODS-5 look for the last dot */
5879 if (decc_efs_charset) {
5880 cp2 = strrchr(cp1,'.');
5882 if (vms_process_case_tolerant) {
5883 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5884 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5885 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5886 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5887 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5888 (ver || *cp3)))))) {
5889 PerlMem_free(trndir);
5890 PerlMem_free(vmsdir);
5892 set_vaxc_errno(RMS$_DIR);
5897 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5898 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5899 !*(cp2+3) || *(cp2+3) != 'R' ||
5900 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5901 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5902 (ver || *cp3)))))) {
5903 PerlMem_free(trndir);
5904 PerlMem_free(vmsdir);
5906 set_vaxc_errno(RMS$_DIR);
5910 dirlen = cp2 - trndir;
5914 retlen = dirlen + 6;
5915 if (buf) retspec = buf;
5916 else if (ts) Newx(retspec,retlen+1,char);
5917 else retspec = __fileify_retbuf;
5918 memcpy(retspec,trndir,dirlen);
5919 retspec[dirlen] = '\0';
5921 /* We've picked up everything up to the directory file name.
5922 Now just add the type and version, and we're set. */
5923 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5924 strcat(retspec,".dir;1");
5926 strcat(retspec,".DIR;1");
5927 PerlMem_free(trndir);
5928 PerlMem_free(vmsdir);
5931 else { /* VMS-style directory spec */
5933 char *esa, term, *cp;
5934 unsigned long int sts, cmplen, haslower = 0;
5935 unsigned int nam_fnb;
5937 struct FAB dirfab = cc$rms_fab;
5938 rms_setup_nam(savnam);
5939 rms_setup_nam(dirnam);
5941 esa = PerlMem_malloc(VMS_MAXRSS + 1);
5942 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5943 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5944 rms_bind_fab_nam(dirfab, dirnam);
5945 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5946 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5947 #ifdef NAM$M_NO_SHORT_UPCASE
5948 if (decc_efs_case_preserve)
5949 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5952 for (cp = trndir; *cp; cp++)
5953 if (islower(*cp)) { haslower = 1; break; }
5954 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5955 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5956 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5957 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5961 PerlMem_free(trndir);
5962 PerlMem_free(vmsdir);
5964 set_vaxc_errno(dirfab.fab$l_sts);
5970 /* Does the file really exist? */
5971 if (sys$search(&dirfab)& STS$K_SUCCESS) {
5972 /* Yes; fake the fnb bits so we'll check type below */
5973 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5975 else { /* No; just work with potential name */
5976 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5979 fab_sts = dirfab.fab$l_sts;
5980 sts = rms_free_search_context(&dirfab);
5982 PerlMem_free(trndir);
5983 PerlMem_free(vmsdir);
5984 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
5989 esa[rms_nam_esll(dirnam)] = '\0';
5990 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5991 cp1 = strchr(esa,']');
5992 if (!cp1) cp1 = strchr(esa,'>');
5993 if (cp1) { /* Should always be true */
5994 rms_nam_esll(dirnam) -= cp1 - esa - 1;
5995 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5998 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5999 /* Yep; check version while we're at it, if it's there. */
6000 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6001 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6002 /* Something other than .DIR[;1]. Bzzt. */
6003 sts = rms_free_search_context(&dirfab);
6005 PerlMem_free(trndir);
6006 PerlMem_free(vmsdir);
6008 set_vaxc_errno(RMS$_DIR);
6013 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6014 /* They provided at least the name; we added the type, if necessary, */
6015 if (buf) retspec = buf; /* in sys$parse() */
6016 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
6017 else retspec = __fileify_retbuf;
6018 strcpy(retspec,esa);
6019 sts = rms_free_search_context(&dirfab);
6020 PerlMem_free(trndir);
6022 PerlMem_free(vmsdir);
6025 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6026 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6028 rms_nam_esll(dirnam) -= 9;
6030 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
6031 if (cp1 == NULL) { /* should never happen */
6032 sts = rms_free_search_context(&dirfab);
6033 PerlMem_free(trndir);
6035 PerlMem_free(vmsdir);
6040 retlen = strlen(esa);
6041 cp1 = strrchr(esa,'.');
6042 /* ODS-5 directory specifications can have extra "." in them. */
6043 /* Fix-me, can not scan EFS file specifications backwards */
6044 while (cp1 != NULL) {
6045 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
6049 while ((cp1 > esa) && (*cp1 != '.'))
6056 if ((cp1) != NULL) {
6057 /* There's more than one directory in the path. Just roll back. */
6059 if (buf) retspec = buf;
6060 else if (ts) Newx(retspec,retlen+7,char);
6061 else retspec = __fileify_retbuf;
6062 strcpy(retspec,esa);
6065 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6066 /* Go back and expand rooted logical name */
6067 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6068 #ifdef NAM$M_NO_SHORT_UPCASE
6069 if (decc_efs_case_preserve)
6070 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6072 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6073 sts = rms_free_search_context(&dirfab);
6075 PerlMem_free(trndir);
6076 PerlMem_free(vmsdir);
6078 set_vaxc_errno(dirfab.fab$l_sts);
6081 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
6082 if (buf) retspec = buf;
6083 else if (ts) Newx(retspec,retlen+16,char);
6084 else retspec = __fileify_retbuf;
6085 cp1 = strstr(esa,"][");
6086 if (!cp1) cp1 = strstr(esa,"]<");
6088 memcpy(retspec,esa,dirlen);
6089 if (!strncmp(cp1+2,"000000]",7)) {
6090 retspec[dirlen-1] = '\0';
6091 /* fix-me Not full ODS-5, just extra dots in directories for now */
6092 cp1 = retspec + dirlen - 1;
6093 while (cp1 > retspec)
6098 if (*(cp1-1) != '^')
6103 if (*cp1 == '.') *cp1 = ']';
6105 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6106 memmove(cp1+1,"000000]",7);
6110 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6111 retspec[retlen] = '\0';
6112 /* Convert last '.' to ']' */
6113 cp1 = retspec+retlen-1;
6114 while (*cp != '[') {
6117 /* Do not trip on extra dots in ODS-5 directories */
6118 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6122 if (*cp1 == '.') *cp1 = ']';
6124 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6125 memmove(cp1+1,"000000]",7);
6129 else { /* This is a top-level dir. Add the MFD to the path. */
6130 if (buf) retspec = buf;
6131 else if (ts) Newx(retspec,retlen+16,char);
6132 else retspec = __fileify_retbuf;
6135 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6136 strcpy(cp2,":[000000]");
6141 sts = rms_free_search_context(&dirfab);
6142 /* We've set up the string up through the filename. Add the
6143 type and version, and we're done. */
6144 strcat(retspec,".DIR;1");
6146 /* $PARSE may have upcased filespec, so convert output to lower
6147 * case if input contained any lowercase characters. */
6148 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6149 PerlMem_free(trndir);
6151 PerlMem_free(vmsdir);
6154 } /* end of do_fileify_dirspec() */
6156 /* External entry points */
6157 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6158 { return do_fileify_dirspec(dir,buf,0,NULL); }
6159 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6160 { return do_fileify_dirspec(dir,buf,1,NULL); }
6161 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6162 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6163 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6164 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6166 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6167 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6169 static char __pathify_retbuf[VMS_MAXRSS];
6170 unsigned long int retlen;
6171 char *retpath, *cp1, *cp2, *trndir;
6172 unsigned short int trnlnm_iter_count;
6175 if (utf8_fl != NULL)
6178 if (!dir || !*dir) {
6179 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6182 trndir = PerlMem_malloc(VMS_MAXRSS);
6183 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
6184 if (*dir) strcpy(trndir,dir);
6185 else getcwd(trndir,VMS_MAXRSS - 1);
6187 trnlnm_iter_count = 0;
6188 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6189 && my_trnlnm(trndir,trndir,0)) {
6190 trnlnm_iter_count++;
6191 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6192 trnlen = strlen(trndir);
6194 /* Trap simple rooted lnms, and return lnm:[000000] */
6195 if (!strcmp(trndir+trnlen-2,".]")) {
6196 if (buf) retpath = buf;
6197 else if (ts) Newx(retpath,strlen(dir)+10,char);
6198 else retpath = __pathify_retbuf;
6199 strcpy(retpath,dir);
6200 strcat(retpath,":[000000]");
6201 PerlMem_free(trndir);
6206 /* At this point we do not work with *dir, but the copy in
6207 * *trndir that is modifiable.
6210 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6211 if (*trndir == '.' && (*(trndir+1) == '\0' ||
6212 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6213 retlen = 2 + (*(trndir+1) != '\0');
6215 if ( !(cp1 = strrchr(trndir,'/')) &&
6216 !(cp1 = strrchr(trndir,']')) &&
6217 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6218 if ((cp2 = strchr(cp1,'.')) != NULL &&
6219 (*(cp2-1) != '/' || /* Trailing '.', '..', */
6220 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
6221 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6222 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6225 /* For EFS or ODS-5 look for the last dot */
6226 if (decc_efs_charset) {
6227 cp2 = strrchr(cp1,'.');
6229 if (vms_process_case_tolerant) {
6230 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6231 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6232 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6233 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6234 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6235 (ver || *cp3)))))) {
6236 PerlMem_free(trndir);
6238 set_vaxc_errno(RMS$_DIR);
6243 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6244 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6245 !*(cp2+3) || *(cp2+3) != 'R' ||
6246 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6247 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6248 (ver || *cp3)))))) {
6249 PerlMem_free(trndir);
6251 set_vaxc_errno(RMS$_DIR);
6255 retlen = cp2 - trndir + 1;
6257 else { /* No file type present. Treat the filename as a directory. */
6258 retlen = strlen(trndir) + 1;
6261 if (buf) retpath = buf;
6262 else if (ts) Newx(retpath,retlen+1,char);
6263 else retpath = __pathify_retbuf;
6264 strncpy(retpath, trndir, retlen-1);
6265 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6266 retpath[retlen-1] = '/'; /* with '/', add it. */
6267 retpath[retlen] = '\0';
6269 else retpath[retlen-1] = '\0';
6271 else { /* VMS-style directory spec */
6273 unsigned long int sts, cmplen, haslower;
6274 struct FAB dirfab = cc$rms_fab;
6276 rms_setup_nam(savnam);
6277 rms_setup_nam(dirnam);
6279 /* If we've got an explicit filename, we can just shuffle the string. */
6280 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6281 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
6282 if ((cp2 = strchr(cp1,'.')) != NULL) {
6284 if (vms_process_case_tolerant) {
6285 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6286 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6287 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6288 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6289 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6290 (ver || *cp3)))))) {
6291 PerlMem_free(trndir);
6293 set_vaxc_errno(RMS$_DIR);
6298 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6299 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6300 !*(cp2+3) || *(cp2+3) != 'R' ||
6301 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6302 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6303 (ver || *cp3)))))) {
6304 PerlMem_free(trndir);
6306 set_vaxc_errno(RMS$_DIR);
6311 else { /* No file type, so just draw name into directory part */
6312 for (cp2 = cp1; *cp2; cp2++) ;
6315 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
6317 /* We've now got a VMS 'path'; fall through */
6320 dirlen = strlen(trndir);
6321 if (trndir[dirlen-1] == ']' ||
6322 trndir[dirlen-1] == '>' ||
6323 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6324 if (buf) retpath = buf;
6325 else if (ts) Newx(retpath,strlen(trndir)+1,char);
6326 else retpath = __pathify_retbuf;
6327 strcpy(retpath,trndir);
6328 PerlMem_free(trndir);
6331 rms_set_fna(dirfab, dirnam, trndir, dirlen);
6332 esa = PerlMem_malloc(VMS_MAXRSS);
6333 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
6334 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6335 rms_bind_fab_nam(dirfab, dirnam);
6336 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
6337 #ifdef NAM$M_NO_SHORT_UPCASE
6338 if (decc_efs_case_preserve)
6339 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6342 for (cp = trndir; *cp; cp++)
6343 if (islower(*cp)) { haslower = 1; break; }
6345 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6346 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6347 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6348 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6351 PerlMem_free(trndir);
6354 set_vaxc_errno(dirfab.fab$l_sts);
6360 /* Does the file really exist? */
6361 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6362 if (dirfab.fab$l_sts != RMS$_FNF) {
6364 sts1 = rms_free_search_context(&dirfab);
6365 PerlMem_free(trndir);
6368 set_vaxc_errno(dirfab.fab$l_sts);
6371 dirnam = savnam; /* No; just work with potential name */
6374 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6375 /* Yep; check version while we're at it, if it's there. */
6376 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6377 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6379 /* Something other than .DIR[;1]. Bzzt. */
6380 sts2 = rms_free_search_context(&dirfab);
6381 PerlMem_free(trndir);
6384 set_vaxc_errno(RMS$_DIR);
6388 /* OK, the type was fine. Now pull any file name into the
6390 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6392 cp1 = strrchr(esa,'>');
6393 *(rms_nam_typel(dirnam)) = '>';
6396 *(rms_nam_typel(dirnam) + 1) = '\0';
6397 retlen = (rms_nam_typel(dirnam)) - esa + 2;
6398 if (buf) retpath = buf;
6399 else if (ts) Newx(retpath,retlen,char);
6400 else retpath = __pathify_retbuf;
6401 strcpy(retpath,esa);
6403 sts = rms_free_search_context(&dirfab);
6404 /* $PARSE may have upcased filespec, so convert output to lower
6405 * case if input contained any lowercase characters. */
6406 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6409 PerlMem_free(trndir);
6411 } /* end of do_pathify_dirspec() */
6413 /* External entry points */
6414 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6415 { return do_pathify_dirspec(dir,buf,0,NULL); }
6416 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6417 { return do_pathify_dirspec(dir,buf,1,NULL); }
6418 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6419 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6420 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6421 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6423 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6424 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6426 static char __tounixspec_retbuf[VMS_MAXRSS];
6427 char *dirend, *rslt, *cp1, *cp3, *tmp;
6429 int devlen, dirlen, retlen = VMS_MAXRSS;
6430 int expand = 1; /* guarantee room for leading and trailing slashes */
6431 unsigned short int trnlnm_iter_count;
6433 if (utf8_fl != NULL)
6436 if (spec == NULL) return NULL;
6437 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6438 if (buf) rslt = buf;
6440 Newx(rslt, VMS_MAXRSS, char);
6442 else rslt = __tounixspec_retbuf;
6444 /* New VMS specific format needs translation
6445 * glob passes filenames with trailing '\n' and expects this preserved.
6447 if (decc_posix_compliant_pathnames) {
6448 if (strncmp(spec, "\"^UP^", 5) == 0) {
6454 tunix = PerlMem_malloc(VMS_MAXRSS);
6455 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
6456 strcpy(tunix, spec);
6457 tunix_len = strlen(tunix);
6459 if (tunix[tunix_len - 1] == '\n') {
6460 tunix[tunix_len - 1] = '\"';
6461 tunix[tunix_len] = '\0';
6465 uspec = decc$translate_vms(tunix);
6466 PerlMem_free(tunix);
6467 if ((int)uspec > 0) {
6473 /* If we can not translate it, makemaker wants as-is */
6481 cmp_rslt = 0; /* Presume VMS */
6482 cp1 = strchr(spec, '/');
6486 /* Look for EFS ^/ */
6487 if (decc_efs_charset) {
6488 while (cp1 != NULL) {
6491 /* Found illegal VMS, assume UNIX */
6496 cp1 = strchr(cp1, '/');
6500 /* Look for "." and ".." */
6501 if (decc_filename_unix_report) {
6502 if (spec[0] == '.') {
6503 if ((spec[1] == '\0') || (spec[1] == '\n')) {
6507 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6513 /* This is already UNIX or at least nothing VMS understands */
6521 dirend = strrchr(spec,']');
6522 if (dirend == NULL) dirend = strrchr(spec,'>');
6523 if (dirend == NULL) dirend = strchr(spec,':');
6524 if (dirend == NULL) {
6529 /* Special case 1 - sys$posix_root = / */
6530 #if __CRTL_VER >= 70000000
6531 if (!decc_disable_posix_root) {
6532 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6540 /* Special case 2 - Convert NLA0: to /dev/null */
6541 #if __CRTL_VER < 70000000
6542 cmp_rslt = strncmp(spec,"NLA0:", 5);
6544 cmp_rslt = strncmp(spec,"nla0:", 5);
6546 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6548 if (cmp_rslt == 0) {
6549 strcpy(rslt, "/dev/null");
6552 if (spec[6] != '\0') {
6559 /* Also handle special case "SYS$SCRATCH:" */
6560 #if __CRTL_VER < 70000000
6561 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6563 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6565 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6567 tmp = PerlMem_malloc(VMS_MAXRSS);
6568 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6569 if (cmp_rslt == 0) {
6572 islnm = my_trnlnm(tmp, "TMP", 0);
6574 strcpy(rslt, "/tmp");
6577 if (spec[12] != '\0') {
6585 if (*cp2 != '[' && *cp2 != '<') {
6588 else { /* the VMS spec begins with directories */
6590 if (*cp2 == ']' || *cp2 == '>') {
6591 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6595 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6596 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6597 if (ts) Safefree(rslt);
6601 trnlnm_iter_count = 0;
6604 while (*cp3 != ':' && *cp3) cp3++;
6606 if (strchr(cp3,']') != NULL) break;
6607 trnlnm_iter_count++;
6608 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6609 } while (vmstrnenv(tmp,tmp,0,fildev,0));
6611 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6612 retlen = devlen + dirlen;
6613 Renew(rslt,retlen+1+2*expand,char);
6619 *(cp1++) = *(cp3++);
6620 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6622 return NULL; /* No room */
6627 if ((*cp2 == '^')) {
6628 /* EFS file escape, pass the next character as is */
6629 /* Fix me: HEX encoding for Unicode not implemented */
6632 else if ( *cp2 == '.') {
6633 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6634 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6641 for (; cp2 <= dirend; cp2++) {
6642 if ((*cp2 == '^')) {
6643 /* EFS file escape, pass the next character as is */
6644 /* Fix me: HEX encoding for Unicode not implemented */
6645 *(cp1++) = *(++cp2);
6646 /* An escaped dot stays as is -- don't convert to slash */
6647 if (*cp2 == '.') cp2++;
6651 if (*(cp2+1) == '[') cp2++;
6653 else if (*cp2 == ']' || *cp2 == '>') {
6654 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6656 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6658 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6659 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6660 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6661 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6662 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6664 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6665 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6669 else if (*cp2 == '-') {
6670 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6671 while (*cp2 == '-') {
6673 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6675 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6676 if (ts) Safefree(rslt); /* filespecs like */
6677 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
6681 else *(cp1++) = *cp2;
6683 else *(cp1++) = *cp2;
6686 if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */
6687 *(cp1++) = *(cp2++);
6691 /* This still leaves /000000/ when working with a
6692 * VMS device root or concealed root.
6698 ulen = strlen(rslt);
6700 /* Get rid of "000000/ in rooted filespecs */
6702 zeros = strstr(rslt, "/000000/");
6703 if (zeros != NULL) {
6705 mlen = ulen - (zeros - rslt) - 7;
6706 memmove(zeros, &zeros[7], mlen);
6715 } /* end of do_tounixspec() */
6717 /* External entry points */
6718 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6719 { return do_tounixspec(spec,buf,0, NULL); }
6720 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6721 { return do_tounixspec(spec,buf,1, NULL); }
6722 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6723 { return do_tounixspec(spec,buf,0, utf8_fl); }
6724 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6725 { return do_tounixspec(spec,buf,1, utf8_fl); }
6727 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6730 This procedure is used to identify if a path is based in either
6731 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6732 it returns the OpenVMS format directory for it.
6734 It is expecting specifications of only '/' or '/xxxx/'
6736 If a posix root does not exist, or 'xxxx' is not a directory
6737 in the posix root, it returns a failure.
6739 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6741 It is used only internally by posix_to_vmsspec_hardway().
6744 static int posix_root_to_vms
6745 (char *vmspath, int vmspath_len,
6746 const char *unixpath,
6747 const int * utf8_fl) {
6749 struct FAB myfab = cc$rms_fab;
6750 struct NAML mynam = cc$rms_naml;
6751 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6752 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6759 unixlen = strlen(unixpath);
6765 #if __CRTL_VER >= 80200000
6766 /* If not a posix spec already, convert it */
6767 if (decc_posix_compliant_pathnames) {
6768 if (strncmp(unixpath,"\"^UP^",5) != 0) {
6769 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6772 /* This is already a VMS specification, no conversion */
6774 strncpy(vmspath,unixpath, vmspath_len);
6783 /* Check to see if this is under the POSIX root */
6784 if (decc_disable_posix_root) {
6788 /* Skip leading / */
6789 if (unixpath[0] == '/') {
6795 strcpy(vmspath,"SYS$POSIX_ROOT:");
6797 /* If this is only the / , or blank, then... */
6798 if (unixpath[0] == '\0') {
6799 /* by definition, this is the answer */
6803 /* Need to look up a directory */
6807 /* Copy and add '^' escape characters as needed */
6810 while (unixpath[i] != 0) {
6813 j += copy_expand_unix_filename_escape
6814 (&vmspath[j], &unixpath[i], &k, utf8_fl);
6818 path_len = strlen(vmspath);
6819 if (vmspath[path_len - 1] == '/')
6821 vmspath[path_len] = ']';
6823 vmspath[path_len] = '\0';
6826 vmspath[vmspath_len] = 0;
6827 if (unixpath[unixlen - 1] == '/')
6829 esa = PerlMem_malloc(VMS_MAXRSS);
6830 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6831 myfab.fab$l_fna = vmspath;
6832 myfab.fab$b_fns = strlen(vmspath);
6833 myfab.fab$l_naml = &mynam;
6834 mynam.naml$l_esa = NULL;
6835 mynam.naml$b_ess = 0;
6836 mynam.naml$l_long_expand = esa;
6837 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6838 mynam.naml$l_rsa = NULL;
6839 mynam.naml$b_rss = 0;
6840 if (decc_efs_case_preserve)
6841 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6842 #ifdef NAML$M_OPEN_SPECIAL
6843 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6846 /* Set up the remaining naml fields */
6847 sts = sys$parse(&myfab);
6849 /* It failed! Try again as a UNIX filespec */
6855 /* get the Device ID and the FID */
6856 sts = sys$search(&myfab);
6857 /* on any failure, returned the POSIX ^UP^ filespec */
6862 specdsc.dsc$a_pointer = vmspath;
6863 specdsc.dsc$w_length = vmspath_len;
6865 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6866 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6867 sts = lib$fid_to_name
6868 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6870 /* on any failure, returned the POSIX ^UP^ filespec */
6872 /* This can happen if user does not have permission to read directories */
6873 if (strncmp(unixpath,"\"^UP^",5) != 0)
6874 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6876 strcpy(vmspath, unixpath);
6879 vmspath[specdsc.dsc$w_length] = 0;
6881 /* Are we expecting a directory? */
6882 if (dir_flag != 0) {
6888 i = specdsc.dsc$w_length - 1;
6892 /* Version must be '1' */
6893 if (vmspath[i--] != '1')
6895 /* Version delimiter is one of ".;" */
6896 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6899 if (vmspath[i--] != 'R')
6901 if (vmspath[i--] != 'I')
6903 if (vmspath[i--] != 'D')
6905 if (vmspath[i--] != '.')
6907 eptr = &vmspath[i+1];
6909 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6910 if (vmspath[i-1] != '^') {
6918 /* Get rid of 6 imaginary zero directory filename */
6919 vmspath[i+1] = '\0';
6923 if (vmspath[i] == '0')
6937 /* /dev/mumble needs to be handled special.
6938 /dev/null becomes NLA0:, And there is the potential for other stuff
6939 like /dev/tty which may need to be mapped to something.
6943 slash_dev_special_to_vms
6944 (const char * unixptr,
6954 nextslash = strchr(unixptr, '/');
6955 len = strlen(unixptr);
6956 if (nextslash != NULL)
6957 len = nextslash - unixptr;
6958 cmp = strncmp("null", unixptr, 5);
6960 if (vmspath_len >= 6) {
6961 strcpy(vmspath, "_NLA0:");
6968 /* The built in routines do not understand perl's special needs, so
6969 doing a manual conversion from UNIX to VMS
6971 If the utf8_fl is not null and points to a non-zero value, then
6972 treat 8 bit characters as UTF-8.
6974 The sequence starting with '$(' and ending with ')' will be passed
6975 through with out interpretation instead of being escaped.
6978 static int posix_to_vmsspec_hardway
6979 (char *vmspath, int vmspath_len,
6980 const char *unixpath,
6985 const char *unixptr;
6986 const char *unixend;
6988 const char *lastslash;
6989 const char *lastdot;
6995 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6996 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6998 if (utf8_fl != NULL)
7004 /* Ignore leading "/" characters */
7005 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7008 unixlen = strlen(unixptr);
7010 /* Do nothing with blank paths */
7017 /* This could have a "^UP^ on the front */
7018 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7024 lastslash = strrchr(unixptr,'/');
7025 lastdot = strrchr(unixptr,'.');
7026 unixend = strrchr(unixptr,'\"');
7027 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7028 unixend = unixptr + unixlen;
7031 /* last dot is last dot or past end of string */
7032 if (lastdot == NULL)
7033 lastdot = unixptr + unixlen;
7035 /* if no directories, set last slash to beginning of string */
7036 if (lastslash == NULL) {
7037 lastslash = unixptr;
7040 /* Watch out for trailing "." after last slash, still a directory */
7041 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7042 lastslash = unixptr + unixlen;
7045 /* Watch out for traiing ".." after last slash, still a directory */
7046 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7047 lastslash = unixptr + unixlen;
7050 /* dots in directories are aways escaped */
7051 if (lastdot < lastslash)
7052 lastdot = unixptr + unixlen;
7055 /* if (unixptr < lastslash) then we are in a directory */
7062 /* Start with the UNIX path */
7063 if (*unixptr != '/') {
7064 /* relative paths */
7066 /* If allowing logical names on relative pathnames, then handle here */
7067 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7068 !decc_posix_compliant_pathnames) {
7074 /* Find the next slash */
7075 nextslash = strchr(unixptr,'/');
7077 esa = PerlMem_malloc(vmspath_len);
7078 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7080 trn = PerlMem_malloc(VMS_MAXRSS);
7081 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7083 if (nextslash != NULL) {
7085 seg_len = nextslash - unixptr;
7086 strncpy(esa, unixptr, seg_len);
7090 strcpy(esa, unixptr);
7091 seg_len = strlen(unixptr);
7093 /* trnlnm(section) */
7094 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7097 /* Now fix up the directory */
7099 /* Split up the path to find the components */
7100 sts = vms_split_path
7119 /* A logical name must be a directory or the full
7120 specification. It is only a full specification if
7121 it is the only component */
7122 if ((unixptr[seg_len] == '\0') ||
7123 (unixptr[seg_len+1] == '\0')) {
7125 /* Is a directory being required? */
7126 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7127 /* Not a logical name */
7132 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7133 /* This must be a directory */
7134 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7135 strcpy(vmsptr, esa);
7136 vmslen=strlen(vmsptr);
7137 vmsptr[vmslen] = ':';
7139 vmsptr[vmslen] = '\0';
7147 /* must be dev/directory - ignore version */
7148 if ((n_len + e_len) != 0)
7151 /* transfer the volume */
7152 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7153 strncpy(vmsptr, v_spec, v_len);
7159 /* unroot the rooted directory */
7160 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7162 r_spec[r_len - 1] = ']';
7164 /* This should not be there, but nothing is perfect */
7166 cmp = strcmp(&r_spec[1], "000000.");
7176 strncpy(vmsptr, r_spec, r_len);
7182 /* Bring over the directory. */
7184 ((d_len + vmslen) < vmspath_len)) {
7186 d_spec[d_len - 1] = ']';
7188 cmp = strcmp(&d_spec[1], "000000.");
7199 /* Remove the redundant root */
7207 strncpy(vmsptr, d_spec, d_len);
7221 if (lastslash > unixptr) {
7224 /* skip leading ./ */
7226 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7232 /* Are we still in a directory? */
7233 if (unixptr <= lastslash) {
7238 /* if not backing up, then it is relative forward. */
7239 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7240 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7248 /* Perl wants an empty directory here to tell the difference
7249 * between a DCL commmand and a filename
7258 /* Handle two special files . and .. */
7259 if (unixptr[0] == '.') {
7260 if (&unixptr[1] == unixend) {
7267 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7278 else { /* Absolute PATH handling */
7282 /* Need to find out where root is */
7284 /* In theory, this procedure should never get an absolute POSIX pathname
7285 * that can not be found on the POSIX root.
7286 * In practice, that can not be relied on, and things will show up
7287 * here that are a VMS device name or concealed logical name instead.
7288 * So to make things work, this procedure must be tolerant.
7290 esa = PerlMem_malloc(vmspath_len);
7291 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7294 nextslash = strchr(&unixptr[1],'/');
7296 if (nextslash != NULL) {
7298 seg_len = nextslash - &unixptr[1];
7299 strncpy(vmspath, unixptr, seg_len + 1);
7300 vmspath[seg_len+1] = 0;
7303 cmp = strncmp(vmspath, "dev", 4);
7305 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7306 if (sts = SS$_NORMAL)
7310 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7313 if ($VMS_STATUS_SUCCESS(sts)) {
7314 /* This is verified to be a real path */
7316 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7317 if ($VMS_STATUS_SUCCESS(sts)) {
7318 strcpy(vmspath, esa);
7319 vmslen = strlen(vmspath);
7320 vmsptr = vmspath + vmslen;
7322 if (unixptr < lastslash) {
7331 cmp = strcmp(rptr,"000000.");
7336 } /* removing 6 zeros */
7337 } /* vmslen < 7, no 6 zeros possible */
7338 } /* Not in a directory */
7339 } /* Posix root found */
7341 /* No posix root, fall back to default directory */
7342 strcpy(vmspath, "SYS$DISK:[");
7343 vmsptr = &vmspath[10];
7345 if (unixptr > lastslash) {
7354 } /* end of verified real path handling */
7359 /* Ok, we have a device or a concealed root that is not in POSIX
7360 * or we have garbage. Make the best of it.
7363 /* Posix to VMS destroyed this, so copy it again */
7364 strncpy(vmspath, &unixptr[1], seg_len);
7365 vmspath[seg_len] = 0;
7367 vmsptr = &vmsptr[vmslen];
7370 /* Now do we need to add the fake 6 zero directory to it? */
7372 if ((*lastslash == '/') && (nextslash < lastslash)) {
7373 /* No there is another directory */
7380 /* now we have foo:bar or foo:[000000]bar to decide from */
7381 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7383 if (!islnm && !decc_posix_compliant_pathnames) {
7385 cmp = strncmp("bin", vmspath, 4);
7387 /* bin => SYS$SYSTEM: */
7388 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7391 /* tmp => SYS$SCRATCH: */
7392 cmp = strncmp("tmp", vmspath, 4);
7394 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7399 trnend = islnm ? islnm - 1 : 0;
7401 /* if this was a logical name, ']' or '>' must be present */
7402 /* if not a logical name, then assume a device and hope. */
7403 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7405 /* if log name and trailing '.' then rooted - treat as device */
7406 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7408 /* Fix me, if not a logical name, a device lookup should be
7409 * done to see if the device is file structured. If the device
7410 * is not file structured, the 6 zeros should not be put on.
7412 * As it is, perl is occasionally looking for dev:[000000]tty.
7413 * which looks a little strange.
7415 * Not that easy to detect as "/dev" may be file structured with
7416 * special device files.
7419 if ((add_6zero == 0) && (*nextslash == '/') &&
7420 (&nextslash[1] == unixend)) {
7421 /* No real directory present */
7426 /* Put the device delimiter on */
7429 unixptr = nextslash;
7432 /* Start directory if needed */
7433 if (!islnm || add_6zero) {
7439 /* add fake 000000] if needed */
7452 } /* non-POSIX translation */
7454 } /* End of relative/absolute path handling */
7456 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7463 if (dir_start != 0) {
7465 /* First characters in a directory are handled special */
7466 while ((*unixptr == '/') ||
7467 ((*unixptr == '.') &&
7468 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7469 (&unixptr[1]==unixend)))) {
7474 /* Skip redundant / in specification */
7475 while ((*unixptr == '/') && (dir_start != 0)) {
7478 if (unixptr == lastslash)
7481 if (unixptr == lastslash)
7484 /* Skip redundant ./ characters */
7485 while ((*unixptr == '.') &&
7486 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7489 if (unixptr == lastslash)
7491 if (*unixptr == '/')
7494 if (unixptr == lastslash)
7497 /* Skip redundant ../ characters */
7498 while ((*unixptr == '.') && (unixptr[1] == '.') &&
7499 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7500 /* Set the backing up flag */
7506 unixptr++; /* first . */
7507 unixptr++; /* second . */
7508 if (unixptr == lastslash)
7510 if (*unixptr == '/') /* The slash */
7513 if (unixptr == lastslash)
7516 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7517 /* Not needed when VMS is pretending to be UNIX. */
7519 /* Is this loop stuck because of too many dots? */
7520 if (loop_flag == 0) {
7521 /* Exit the loop and pass the rest through */
7526 /* Are we done with directories yet? */
7527 if (unixptr >= lastslash) {
7529 /* Watch out for trailing dots */
7538 if (*unixptr == '/')
7542 /* Have we stopped backing up? */
7547 /* dir_start continues to be = 1 */
7549 if (*unixptr == '-') {
7551 *vmsptr++ = *unixptr++;
7555 /* Now are we done with directories yet? */
7556 if (unixptr >= lastslash) {
7558 /* Watch out for trailing dots */
7574 if (unixptr >= unixend)
7577 /* Normal characters - More EFS work probably needed */
7583 /* remove multiple / */
7584 while (unixptr[1] == '/') {
7587 if (unixptr == lastslash) {
7588 /* Watch out for trailing dots */
7600 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7601 /* Not needed when VMS is pretending to be UNIX. */
7605 if (unixptr != unixend)
7610 if ((unixptr < lastdot) || (unixptr < lastslash) ||
7611 (&unixptr[1] == unixend)) {
7617 /* trailing dot ==> '^..' on VMS */
7618 if (unixptr == unixend) {
7626 *vmsptr++ = *unixptr++;
7630 if (quoted && (&unixptr[1] == unixend)) {
7634 in_cnt = copy_expand_unix_filename_escape
7635 (vmsptr, unixptr, &out_cnt, utf8_fl);
7645 in_cnt = copy_expand_unix_filename_escape
7646 (vmsptr, unixptr, &out_cnt, utf8_fl);
7653 /* Make sure directory is closed */
7654 if (unixptr == lastslash) {
7656 vmsptr2 = vmsptr - 1;
7658 if (*vmsptr2 != ']') {
7661 /* directories do not end in a dot bracket */
7662 if (*vmsptr2 == '.') {
7666 if (*vmsptr2 != '^') {
7667 vmsptr--; /* back up over the dot */
7675 /* Add a trailing dot if a file with no extension */
7676 vmsptr2 = vmsptr - 1;
7678 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7679 (*vmsptr2 != ')') && (*lastdot != '.')) {
7690 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7691 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7696 /* If a UTF8 flag is being passed, honor it */
7698 if (utf8_fl != NULL) {
7699 utf8_flag = *utf8_fl;
7704 /* If there is a possibility of UTF8, then if any UTF8 characters
7705 are present, then they must be converted to VTF-7
7707 result = strcpy(rslt, path); /* FIX-ME */
7710 result = strcpy(rslt, path);
7716 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7717 static char *mp_do_tovmsspec
7718 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7719 static char __tovmsspec_retbuf[VMS_MAXRSS];
7720 char *rslt, *dirend;
7725 unsigned long int infront = 0, hasdir = 1;
7728 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7729 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7731 if (path == NULL) return NULL;
7732 rslt_len = VMS_MAXRSS-1;
7733 if (buf) rslt = buf;
7734 else if (ts) Newx(rslt, VMS_MAXRSS, char);
7735 else rslt = __tovmsspec_retbuf;
7737 /* '.' and '..' are "[]" and "[-]" for a quick check */
7738 if (path[0] == '.') {
7739 if (path[1] == '\0') {
7741 if (utf8_flag != NULL)
7746 if (path[1] == '.' && path[2] == '\0') {
7748 if (utf8_flag != NULL)
7755 /* Posix specifications are now a native VMS format */
7756 /*--------------------------------------------------*/
7757 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7758 if (decc_posix_compliant_pathnames) {
7759 if (strncmp(path,"\"^UP^",5) == 0) {
7760 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7766 /* This is really the only way to see if this is already in VMS format */
7767 sts = vms_split_path
7782 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7783 replacement, because the above parse just took care of most of
7784 what is needed to do vmspath when the specification is already
7787 And if it is not already, it is easier to do the conversion as
7788 part of this routine than to call this routine and then work on
7792 /* If VMS punctuation was found, it is already VMS format */
7793 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7794 if (utf8_flag != NULL)
7799 /* Now, what to do with trailing "." cases where there is no
7800 extension? If this is a UNIX specification, and EFS characters
7801 are enabled, then the trailing "." should be converted to a "^.".
7802 But if this was already a VMS specification, then it should be
7805 So in the case of ambiguity, leave the specification alone.
7809 /* If there is a possibility of UTF8, then if any UTF8 characters
7810 are present, then they must be converted to VTF-7
7812 if (utf8_flag != NULL)
7818 dirend = strrchr(path,'/');
7820 if (dirend == NULL) {
7821 /* If we get here with no UNIX directory delimiters, then this is
7822 not a complete file specification, either garbage a UNIX glob
7823 specification that can not be converted to a VMS wildcard, or
7824 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7825 so apparently other programs expect this also.
7827 utf8 flag setting needs to be preserved.
7833 /* If POSIX mode active, handle the conversion */
7834 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7835 if (decc_efs_charset) {
7836 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7841 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
7842 if (!*(dirend+2)) dirend +=2;
7843 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7844 if (decc_efs_charset == 0) {
7845 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7851 lastdot = strrchr(cp2,'.');
7857 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7859 if (decc_disable_posix_root) {
7860 strcpy(rslt,"sys$disk:[000000]");
7863 strcpy(rslt,"sys$posix_root:[000000]");
7865 if (utf8_flag != NULL)
7869 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7871 trndev = PerlMem_malloc(VMS_MAXRSS);
7872 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7873 islnm = my_trnlnm(rslt,trndev,0);
7875 /* DECC special handling */
7877 if (strcmp(rslt,"bin") == 0) {
7878 strcpy(rslt,"sys$system");
7881 islnm = my_trnlnm(rslt,trndev,0);
7883 else if (strcmp(rslt,"tmp") == 0) {
7884 strcpy(rslt,"sys$scratch");
7887 islnm = my_trnlnm(rslt,trndev,0);
7889 else if (!decc_disable_posix_root) {
7890 strcpy(rslt, "sys$posix_root");
7894 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7895 islnm = my_trnlnm(rslt,trndev,0);
7897 else if (strcmp(rslt,"dev") == 0) {
7898 if (strncmp(cp2,"/null", 5) == 0) {
7899 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7900 strcpy(rslt,"NLA0");
7904 islnm = my_trnlnm(rslt,trndev,0);
7910 trnend = islnm ? strlen(trndev) - 1 : 0;
7911 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7912 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7913 /* If the first element of the path is a logical name, determine
7914 * whether it has to be translated so we can add more directories. */
7915 if (!islnm || rooted) {
7918 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7922 if (cp2 != dirend) {
7923 strcpy(rslt,trndev);
7924 cp1 = rslt + trnend;
7931 if (decc_disable_posix_root) {
7937 PerlMem_free(trndev);
7942 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7943 cp2 += 2; /* skip over "./" - it's redundant */
7944 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
7946 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7947 *(cp1++) = '-'; /* "../" --> "-" */
7950 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7951 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7952 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7953 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7956 else if ((cp2 != lastdot) || (lastdot < dirend)) {
7957 /* Escape the extra dots in EFS file specifications */
7960 if (cp2 > dirend) cp2 = dirend;
7962 else *(cp1++) = '.';
7964 for (; cp2 < dirend; cp2++) {
7966 if (*(cp2-1) == '/') continue;
7967 if (*(cp1-1) != '.') *(cp1++) = '.';
7970 else if (!infront && *cp2 == '.') {
7971 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7972 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
7973 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7974 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7975 else if (*(cp1-2) == '[') *(cp1-1) = '-';
7976 else { /* back up over previous directory name */
7978 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7979 if (*(cp1-1) == '[') {
7980 memcpy(cp1,"000000.",7);
7985 if (cp2 == dirend) break;
7987 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7988 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7989 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7990 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7992 *(cp1++) = '.'; /* Simulate trailing '/' */
7993 cp2 += 2; /* for loop will incr this to == dirend */
7995 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
7998 if (decc_efs_charset == 0)
7999 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8001 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8007 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
8009 if (decc_efs_charset == 0)
8016 else *(cp1++) = *cp2;
8020 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8021 if (hasdir) *(cp1++) = ']';
8022 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
8023 /* fixme for ODS5 */
8030 if (decc_efs_charset == 0)
8041 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8042 decc_readdir_dropdotnotype) {
8047 /* trailing dot ==> '^..' on VMS */
8054 *(cp1++) = *(cp2++);
8059 /* This could be a macro to be passed through */
8060 *(cp1++) = *(cp2++);
8062 const char * save_cp2;
8066 /* paranoid check */
8072 *(cp1++) = *(cp2++);
8073 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8074 *(cp1++) = *(cp2++);
8075 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8076 *(cp1++) = *(cp2++);
8079 *(cp1++) = *(cp2++);
8083 if (is_macro == 0) {
8084 /* Not really a macro - never mind */
8097 /* Don't escape again if following character is
8098 * already something we escape.
8100 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8101 *(cp1++) = *(cp2++);
8104 /* But otherwise fall through and escape it. */
8122 *(cp1++) = *(cp2++);
8125 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8126 * which is wrong. UNIX notation should be ".dir." unless
8127 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8128 * changing this behavior could break more things at this time.
8129 * efs character set effectively does not allow "." to be a version
8130 * delimiter as a further complication about changing this.
8132 if (decc_filename_unix_report != 0) {
8135 *(cp1++) = *(cp2++);
8138 *(cp1++) = *(cp2++);
8141 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8145 /* Fix me for "^]", but that requires making sure that you do
8146 * not back up past the start of the filename
8148 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8153 if (utf8_flag != NULL)
8157 } /* end of do_tovmsspec() */
8159 /* External entry points */
8160 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8161 { return do_tovmsspec(path,buf,0,NULL); }
8162 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8163 { return do_tovmsspec(path,buf,1,NULL); }
8164 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8165 { return do_tovmsspec(path,buf,0,utf8_fl); }
8166 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8167 { return do_tovmsspec(path,buf,1,utf8_fl); }
8169 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8170 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8171 static char __tovmspath_retbuf[VMS_MAXRSS];
8173 char *pathified, *vmsified, *cp;
8175 if (path == NULL) return NULL;
8176 pathified = PerlMem_malloc(VMS_MAXRSS);
8177 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8178 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8179 PerlMem_free(pathified);
8185 Newx(vmsified, VMS_MAXRSS, char);
8186 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8187 PerlMem_free(pathified);
8188 if (vmsified) Safefree(vmsified);
8191 PerlMem_free(pathified);
8196 vmslen = strlen(vmsified);
8197 Newx(cp,vmslen+1,char);
8198 memcpy(cp,vmsified,vmslen);
8204 strcpy(__tovmspath_retbuf,vmsified);
8206 return __tovmspath_retbuf;
8209 } /* end of do_tovmspath() */
8211 /* External entry points */
8212 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8213 { return do_tovmspath(path,buf,0, NULL); }
8214 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8215 { return do_tovmspath(path,buf,1, NULL); }
8216 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8217 { return do_tovmspath(path,buf,0,utf8_fl); }
8218 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8219 { return do_tovmspath(path,buf,1,utf8_fl); }
8222 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8223 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8224 static char __tounixpath_retbuf[VMS_MAXRSS];
8226 char *pathified, *unixified, *cp;
8228 if (path == NULL) return NULL;
8229 pathified = PerlMem_malloc(VMS_MAXRSS);
8230 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8231 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8232 PerlMem_free(pathified);
8238 Newx(unixified, VMS_MAXRSS, char);
8240 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8241 PerlMem_free(pathified);
8242 if (unixified) Safefree(unixified);
8245 PerlMem_free(pathified);
8250 unixlen = strlen(unixified);
8251 Newx(cp,unixlen+1,char);
8252 memcpy(cp,unixified,unixlen);
8254 Safefree(unixified);
8258 strcpy(__tounixpath_retbuf,unixified);
8259 Safefree(unixified);
8260 return __tounixpath_retbuf;
8263 } /* end of do_tounixpath() */
8265 /* External entry points */
8266 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8267 { return do_tounixpath(path,buf,0,NULL); }
8268 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8269 { return do_tounixpath(path,buf,1,NULL); }
8270 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8271 { return do_tounixpath(path,buf,0,utf8_fl); }
8272 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8273 { return do_tounixpath(path,buf,1,utf8_fl); }
8276 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
8278 *****************************************************************************
8280 * Copyright (C) 1989-1994, 2007 by *
8281 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
8283 * Permission is hereby granted for the reproduction of this software *
8284 * on condition that this copyright notice is included in source *
8285 * distributions of the software. The code may be modified and *
8286 * distributed under the same terms as Perl itself. *
8288 * 27-Aug-1994 Modified for inclusion in perl5 *
8289 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
8290 *****************************************************************************
8294 * getredirection() is intended to aid in porting C programs
8295 * to VMS (Vax-11 C). The native VMS environment does not support
8296 * '>' and '<' I/O redirection, or command line wild card expansion,
8297 * or a command line pipe mechanism using the '|' AND background
8298 * command execution '&'. All of these capabilities are provided to any
8299 * C program which calls this procedure as the first thing in the
8301 * The piping mechanism will probably work with almost any 'filter' type
8302 * of program. With suitable modification, it may useful for other
8303 * portability problems as well.
8305 * Author: Mark Pizzolato (mark AT infocomm DOT com)
8309 struct list_item *next;
8313 static void add_item(struct list_item **head,
8314 struct list_item **tail,
8318 static void mp_expand_wild_cards(pTHX_ char *item,
8319 struct list_item **head,
8320 struct list_item **tail,
8323 static int background_process(pTHX_ int argc, char **argv);
8325 static void pipe_and_fork(pTHX_ char **cmargv);
8327 /*{{{ void getredirection(int *ac, char ***av)*/
8329 mp_getredirection(pTHX_ int *ac, char ***av)
8331 * Process vms redirection arg's. Exit if any error is seen.
8332 * If getredirection() processes an argument, it is erased
8333 * from the vector. getredirection() returns a new argc and argv value.
8334 * In the event that a background command is requested (by a trailing "&"),
8335 * this routine creates a background subprocess, and simply exits the program.
8337 * Warning: do not try to simplify the code for vms. The code
8338 * presupposes that getredirection() is called before any data is
8339 * read from stdin or written to stdout.
8341 * Normal usage is as follows:
8347 * getredirection(&argc, &argv);
8351 int argc = *ac; /* Argument Count */
8352 char **argv = *av; /* Argument Vector */
8353 char *ap; /* Argument pointer */
8354 int j; /* argv[] index */
8355 int item_count = 0; /* Count of Items in List */
8356 struct list_item *list_head = 0; /* First Item in List */
8357 struct list_item *list_tail; /* Last Item in List */
8358 char *in = NULL; /* Input File Name */
8359 char *out = NULL; /* Output File Name */
8360 char *outmode = "w"; /* Mode to Open Output File */
8361 char *err = NULL; /* Error File Name */
8362 char *errmode = "w"; /* Mode to Open Error File */
8363 int cmargc = 0; /* Piped Command Arg Count */
8364 char **cmargv = NULL;/* Piped Command Arg Vector */
8367 * First handle the case where the last thing on the line ends with
8368 * a '&'. This indicates the desire for the command to be run in a
8369 * subprocess, so we satisfy that desire.
8372 if (0 == strcmp("&", ap))
8373 exit(background_process(aTHX_ --argc, argv));
8374 if (*ap && '&' == ap[strlen(ap)-1])
8376 ap[strlen(ap)-1] = '\0';
8377 exit(background_process(aTHX_ argc, argv));
8380 * Now we handle the general redirection cases that involve '>', '>>',
8381 * '<', and pipes '|'.
8383 for (j = 0; j < argc; ++j)
8385 if (0 == strcmp("<", argv[j]))
8389 fprintf(stderr,"No input file after < on command line");
8390 exit(LIB$_WRONUMARG);
8395 if ('<' == *(ap = argv[j]))
8400 if (0 == strcmp(">", ap))
8404 fprintf(stderr,"No output file after > on command line");
8405 exit(LIB$_WRONUMARG);
8424 fprintf(stderr,"No output file after > or >> on command line");
8425 exit(LIB$_WRONUMARG);
8429 if (('2' == *ap) && ('>' == ap[1]))
8446 fprintf(stderr,"No output file after 2> or 2>> on command line");
8447 exit(LIB$_WRONUMARG);
8451 if (0 == strcmp("|", argv[j]))
8455 fprintf(stderr,"No command into which to pipe on command line");
8456 exit(LIB$_WRONUMARG);
8458 cmargc = argc-(j+1);
8459 cmargv = &argv[j+1];
8463 if ('|' == *(ap = argv[j]))
8471 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8474 * Allocate and fill in the new argument vector, Some Unix's terminate
8475 * the list with an extra null pointer.
8477 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8478 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8480 for (j = 0; j < item_count; ++j, list_head = list_head->next)
8481 argv[j] = list_head->value;
8487 fprintf(stderr,"'|' and '>' may not both be specified on command line");
8488 exit(LIB$_INVARGORD);
8490 pipe_and_fork(aTHX_ cmargv);
8493 /* Check for input from a pipe (mailbox) */
8495 if (in == NULL && 1 == isapipe(0))
8497 char mbxname[L_tmpnam];
8499 long int dvi_item = DVI$_DEVBUFSIZ;
8500 $DESCRIPTOR(mbxnam, "");
8501 $DESCRIPTOR(mbxdevnam, "");
8503 /* Input from a pipe, reopen it in binary mode to disable */
8504 /* carriage control processing. */
8506 fgetname(stdin, mbxname);
8507 mbxnam.dsc$a_pointer = mbxname;
8508 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8509 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8510 mbxdevnam.dsc$a_pointer = mbxname;
8511 mbxdevnam.dsc$w_length = sizeof(mbxname);
8512 dvi_item = DVI$_DEVNAM;
8513 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8514 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8517 freopen(mbxname, "rb", stdin);
8520 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8524 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8526 fprintf(stderr,"Can't open input file %s as stdin",in);
8529 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8531 fprintf(stderr,"Can't open output file %s as stdout",out);
8534 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8537 if (strcmp(err,"&1") == 0) {
8538 dup2(fileno(stdout), fileno(stderr));
8539 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8542 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8544 fprintf(stderr,"Can't open error file %s as stderr",err);
8548 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8552 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8555 #ifdef ARGPROC_DEBUG
8556 PerlIO_printf(Perl_debug_log, "Arglist:\n");
8557 for (j = 0; j < *ac; ++j)
8558 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8560 /* Clear errors we may have hit expanding wildcards, so they don't
8561 show up in Perl's $! later */
8562 set_errno(0); set_vaxc_errno(1);
8563 } /* end of getredirection() */
8566 static void add_item(struct list_item **head,
8567 struct list_item **tail,
8573 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8574 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8578 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8579 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8580 *tail = (*tail)->next;
8582 (*tail)->value = value;
8586 static void mp_expand_wild_cards(pTHX_ char *item,
8587 struct list_item **head,
8588 struct list_item **tail,
8592 unsigned long int context = 0;
8600 $DESCRIPTOR(filespec, "");
8601 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8602 $DESCRIPTOR(resultspec, "");
8603 unsigned long int lff_flags = 0;
8607 #ifdef VMS_LONGNAME_SUPPORT
8608 lff_flags = LIB$M_FIL_LONG_NAMES;
8611 for (cp = item; *cp; cp++) {
8612 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8613 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8615 if (!*cp || isspace(*cp))
8617 add_item(head, tail, item, count);
8622 /* "double quoted" wild card expressions pass as is */
8623 /* From DCL that means using e.g.: */
8624 /* perl program """perl.*""" */
8625 item_len = strlen(item);
8626 if ( '"' == *item && '"' == item[item_len-1] )
8629 item[item_len-2] = '\0';
8630 add_item(head, tail, item, count);
8634 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8635 resultspec.dsc$b_class = DSC$K_CLASS_D;
8636 resultspec.dsc$a_pointer = NULL;
8637 vmsspec = PerlMem_malloc(VMS_MAXRSS);
8638 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8639 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8640 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8641 if (!isunix || !filespec.dsc$a_pointer)
8642 filespec.dsc$a_pointer = item;
8643 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8645 * Only return version specs, if the caller specified a version
8647 had_version = strchr(item, ';');
8649 * Only return device and directory specs, if the caller specifed either.
8651 had_device = strchr(item, ':');
8652 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8654 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8655 (&filespec, &resultspec, &context,
8656 &defaultspec, 0, &rms_sts, &lff_flags)))
8661 string = PerlMem_malloc(resultspec.dsc$w_length+1);
8662 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8663 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8664 string[resultspec.dsc$w_length] = '\0';
8665 if (NULL == had_version)
8666 *(strrchr(string, ';')) = '\0';
8667 if ((!had_directory) && (had_device == NULL))
8669 if (NULL == (devdir = strrchr(string, ']')))
8670 devdir = strrchr(string, '>');
8671 strcpy(string, devdir + 1);
8674 * Be consistent with what the C RTL has already done to the rest of
8675 * the argv items and lowercase all of these names.
8677 if (!decc_efs_case_preserve) {
8678 for (c = string; *c; ++c)
8682 if (isunix) trim_unixpath(string,item,1);
8683 add_item(head, tail, string, count);
8686 PerlMem_free(vmsspec);
8687 if (sts != RMS$_NMF)
8689 set_vaxc_errno(sts);
8692 case RMS$_FNF: case RMS$_DNF:
8693 set_errno(ENOENT); break;
8695 set_errno(ENOTDIR); break;
8697 set_errno(ENODEV); break;
8698 case RMS$_FNM: case RMS$_SYN:
8699 set_errno(EINVAL); break;
8701 set_errno(EACCES); break;
8703 _ckvmssts_noperl(sts);
8707 add_item(head, tail, item, count);
8708 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8709 _ckvmssts_noperl(lib$find_file_end(&context));
8712 static int child_st[2];/* Event Flag set when child process completes */
8714 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
8716 static unsigned long int exit_handler(int *status)
8720 if (0 == child_st[0])
8722 #ifdef ARGPROC_DEBUG
8723 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8725 fflush(stdout); /* Have to flush pipe for binary data to */
8726 /* terminate properly -- <tp@mccall.com> */
8727 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8728 sys$dassgn(child_chan);
8730 sys$synch(0, child_st);
8735 static void sig_child(int chan)
8737 #ifdef ARGPROC_DEBUG
8738 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8740 if (child_st[0] == 0)
8744 static struct exit_control_block exit_block =
8749 &exit_block.exit_status,
8754 pipe_and_fork(pTHX_ char **cmargv)
8757 struct dsc$descriptor_s *vmscmd;
8758 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8759 int sts, j, l, ismcr, quote, tquote = 0;
8761 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
8762 vms_execfree(vmscmd);
8767 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
8768 && toupper(*(q+2)) == 'R' && !*(q+3);
8770 while (q && l < MAX_DCL_LINE_LENGTH) {
8772 if (j > 0 && quote) {
8778 if (ismcr && j > 1) quote = 1;
8779 tquote = (strchr(q,' ')) != NULL || *q == '\0';
8782 if (quote || tquote) {
8788 if ((quote||tquote) && *q == '"') {
8798 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8800 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8804 static int background_process(pTHX_ int argc, char **argv)
8806 char command[MAX_DCL_SYMBOL + 1] = "$";
8807 $DESCRIPTOR(value, "");
8808 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8809 static $DESCRIPTOR(null, "NLA0:");
8810 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8812 $DESCRIPTOR(pidstr, "");
8814 unsigned long int flags = 17, one = 1, retsts;
8817 strcat(command, argv[0]);
8818 len = strlen(command);
8819 while (--argc && (len < MAX_DCL_SYMBOL))
8821 strcat(command, " \"");
8822 strcat(command, *(++argv));
8823 strcat(command, "\"");
8824 len = strlen(command);
8826 value.dsc$a_pointer = command;
8827 value.dsc$w_length = strlen(value.dsc$a_pointer);
8828 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8829 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8830 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8831 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8834 _ckvmssts_noperl(retsts);
8836 #ifdef ARGPROC_DEBUG
8837 PerlIO_printf(Perl_debug_log, "%s\n", command);
8839 sprintf(pidstring, "%08X", pid);
8840 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8841 pidstr.dsc$a_pointer = pidstring;
8842 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8843 lib$set_symbol(&pidsymbol, &pidstr);
8847 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8850 /* OS-specific initialization at image activation (not thread startup) */
8851 /* Older VAXC header files lack these constants */
8852 #ifndef JPI$_RIGHTS_SIZE
8853 # define JPI$_RIGHTS_SIZE 817
8855 #ifndef KGB$M_SUBSYSTEM
8856 # define KGB$M_SUBSYSTEM 0x8
8859 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8861 /*{{{void vms_image_init(int *, char ***)*/
8863 vms_image_init(int *argcp, char ***argvp)
8865 char eqv[LNM$C_NAMLENGTH+1] = "";
8866 unsigned int len, tabct = 8, tabidx = 0;
8867 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8868 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8869 unsigned short int dummy, rlen;
8870 struct dsc$descriptor_s **tabvec;
8871 #if defined(PERL_IMPLICIT_CONTEXT)
8874 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8875 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8876 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8879 #ifdef KILL_BY_SIGPRC
8880 Perl_csighandler_init();
8883 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8884 _ckvmssts_noperl(iosb[0]);
8885 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8886 if (iprv[i]) { /* Running image installed with privs? */
8887 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
8892 /* Rights identifiers might trigger tainting as well. */
8893 if (!will_taint && (rlen || rsz)) {
8894 while (rlen < rsz) {
8895 /* We didn't get all the identifiers on the first pass. Allocate a
8896 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8897 * were needed to hold all identifiers at time of last call; we'll
8898 * allocate that many unsigned long ints), and go back and get 'em.
8899 * If it gave us less than it wanted to despite ample buffer space,
8900 * something's broken. Is your system missing a system identifier?
8902 if (rsz <= jpilist[1].buflen) {
8903 /* Perl_croak accvios when used this early in startup. */
8904 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8905 rsz, (unsigned long) jpilist[1].buflen,
8906 "Check your rights database for corruption.\n");
8909 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8910 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8911 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8912 jpilist[1].buflen = rsz * sizeof(unsigned long int);
8913 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8914 _ckvmssts_noperl(iosb[0]);
8916 mask = jpilist[1].bufadr;
8917 /* Check attribute flags for each identifier (2nd longword); protected
8918 * subsystem identifiers trigger tainting.
8920 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8921 if (mask[i] & KGB$M_SUBSYSTEM) {
8926 if (mask != rlst) PerlMem_free(mask);
8929 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8930 * logical, some versions of the CRTL will add a phanthom /000000/
8931 * directory. This needs to be removed.
8933 if (decc_filename_unix_report) {
8936 ulen = strlen(argvp[0][0]);
8938 zeros = strstr(argvp[0][0], "/000000/");
8939 if (zeros != NULL) {
8941 mlen = ulen - (zeros - argvp[0][0]) - 7;
8942 memmove(zeros, &zeros[7], mlen);
8944 argvp[0][0][ulen] = '\0';
8947 /* It also may have a trailing dot that needs to be removed otherwise
8948 * it will be converted to VMS mode incorrectly.
8951 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8952 argvp[0][0][ulen] = '\0';
8955 /* We need to use this hack to tell Perl it should run with tainting,
8956 * since its tainting flag may be part of the PL_curinterp struct, which
8957 * hasn't been allocated when vms_image_init() is called.
8960 char **newargv, **oldargv;
8962 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8963 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8964 newargv[0] = oldargv[0];
8965 newargv[1] = PerlMem_malloc(3 * sizeof(char));
8966 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8967 strcpy(newargv[1], "-T");
8968 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8970 newargv[*argcp] = NULL;
8971 /* We orphan the old argv, since we don't know where it's come from,
8972 * so we don't know how to free it.
8976 else { /* Did user explicitly request tainting? */
8978 char *cp, **av = *argvp;
8979 for (i = 1; i < *argcp; i++) {
8980 if (*av[i] != '-') break;
8981 for (cp = av[i]+1; *cp; cp++) {
8982 if (*cp == 'T') { will_taint = 1; break; }
8983 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8984 strchr("DFIiMmx",*cp)) break;
8986 if (will_taint) break;
8991 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8994 tabvec = (struct dsc$descriptor_s **)
8995 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8996 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8998 else if (tabidx >= tabct) {
9000 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9001 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9003 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9004 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9005 tabvec[tabidx]->dsc$w_length = 0;
9006 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9007 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9008 tabvec[tabidx]->dsc$a_pointer = NULL;
9009 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9011 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9013 getredirection(argcp,argvp);
9014 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9016 # include <reentrancy.h>
9017 decc$set_reentrancy(C$C_MULTITHREAD);
9026 * Trim Unix-style prefix off filespec, so it looks like what a shell
9027 * glob expansion would return (i.e. from specified prefix on, not
9028 * full path). Note that returned filespec is Unix-style, regardless
9029 * of whether input filespec was VMS-style or Unix-style.
9031 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9032 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9033 * vector of options; at present, only bit 0 is used, and if set tells
9034 * trim unixpath to try the current default directory as a prefix when
9035 * presented with a possibly ambiguous ... wildcard.
9037 * Returns !=0 on success, with trimmed filespec replacing contents of
9038 * fspec, and 0 on failure, with contents of fpsec unchanged.
9040 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9042 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9044 char *unixified, *unixwild,
9045 *template, *base, *end, *cp1, *cp2;
9046 register int tmplen, reslen = 0, dirs = 0;
9048 unixwild = PerlMem_malloc(VMS_MAXRSS);
9049 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
9050 if (!wildspec || !fspec) return 0;
9051 template = unixwild;
9052 if (strpbrk(wildspec,"]>:") != NULL) {
9053 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
9054 PerlMem_free(unixwild);
9059 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9060 unixwild[VMS_MAXRSS-1] = 0;
9062 unixified = PerlMem_malloc(VMS_MAXRSS);
9063 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
9064 if (strpbrk(fspec,"]>:") != NULL) {
9065 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9066 PerlMem_free(unixwild);
9067 PerlMem_free(unixified);
9070 else base = unixified;
9071 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9072 * check to see that final result fits into (isn't longer than) fspec */
9073 reslen = strlen(fspec);
9077 /* No prefix or absolute path on wildcard, so nothing to remove */
9078 if (!*template || *template == '/') {
9079 PerlMem_free(unixwild);
9080 if (base == fspec) {
9081 PerlMem_free(unixified);
9084 tmplen = strlen(unixified);
9085 if (tmplen > reslen) {
9086 PerlMem_free(unixified);
9087 return 0; /* not enough space */
9089 /* Copy unixified resultant, including trailing NUL */
9090 memmove(fspec,unixified,tmplen+1);
9091 PerlMem_free(unixified);
9095 for (end = base; *end; end++) ; /* Find end of resultant filespec */
9096 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9097 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9098 for (cp1 = end ;cp1 >= base; cp1--)
9099 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9101 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9102 PerlMem_free(unixified);
9103 PerlMem_free(unixwild);
9108 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9109 int ells = 1, totells, segdirs, match;
9110 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9111 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9113 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9115 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9116 tpl = PerlMem_malloc(VMS_MAXRSS);
9117 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
9118 if (ellipsis == template && opts & 1) {
9119 /* Template begins with an ellipsis. Since we can't tell how many
9120 * directory names at the front of the resultant to keep for an
9121 * arbitrary starting point, we arbitrarily choose the current
9122 * default directory as a starting point. If it's there as a prefix,
9123 * clip it off. If not, fall through and act as if the leading
9124 * ellipsis weren't there (i.e. return shortest possible path that
9125 * could match template).
9127 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9129 PerlMem_free(unixified);
9130 PerlMem_free(unixwild);
9133 if (!decc_efs_case_preserve) {
9134 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9135 if (_tolower(*cp1) != _tolower(*cp2)) break;
9137 segdirs = dirs - totells; /* Min # of dirs we must have left */
9138 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9139 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9140 memmove(fspec,cp2+1,end - cp2);
9142 PerlMem_free(unixified);
9143 PerlMem_free(unixwild);
9147 /* First off, back up over constant elements at end of path */
9149 for (front = end ; front >= base; front--)
9150 if (*front == '/' && !dirs--) { front++; break; }
9152 lcres = PerlMem_malloc(VMS_MAXRSS);
9153 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
9154 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9156 if (!decc_efs_case_preserve) {
9157 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9165 PerlMem_free(unixified);
9166 PerlMem_free(unixwild);
9167 PerlMem_free(lcres);
9168 return 0; /* Path too long. */
9171 *cp2 = '\0'; /* Pick up with memcpy later */
9172 lcfront = lcres + (front - base);
9173 /* Now skip over each ellipsis and try to match the path in front of it. */
9175 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9176 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9177 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
9178 if (cp1 < template) break; /* template started with an ellipsis */
9179 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9180 ellipsis = cp1; continue;
9182 wilddsc.dsc$a_pointer = tpl;
9183 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9185 for (segdirs = 0, cp2 = tpl;
9186 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9188 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9190 if (!decc_efs_case_preserve) {
9191 *cp2 = _tolower(*cp1); /* else lowercase for match */
9194 *cp2 = *cp1; /* else preserve case for match */
9197 if (*cp2 == '/') segdirs++;
9199 if (cp1 != ellipsis - 1) {
9201 PerlMem_free(unixified);
9202 PerlMem_free(unixwild);
9203 PerlMem_free(lcres);
9204 return 0; /* Path too long */
9206 /* Back up at least as many dirs as in template before matching */
9207 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9208 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9209 for (match = 0; cp1 > lcres;) {
9210 resdsc.dsc$a_pointer = cp1;
9211 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9213 if (match == 1) lcfront = cp1;
9215 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9219 PerlMem_free(unixified);
9220 PerlMem_free(unixwild);
9221 PerlMem_free(lcres);
9222 return 0; /* Can't find prefix ??? */
9224 if (match > 1 && opts & 1) {
9225 /* This ... wildcard could cover more than one set of dirs (i.e.
9226 * a set of similar dir names is repeated). If the template
9227 * contains more than 1 ..., upstream elements could resolve the
9228 * ambiguity, but it's not worth a full backtracking setup here.
9229 * As a quick heuristic, clip off the current default directory
9230 * if it's present to find the trimmed spec, else use the
9231 * shortest string that this ... could cover.
9233 char def[NAM$C_MAXRSS+1], *st;
9235 if (getcwd(def, sizeof def,0) == NULL) {
9236 Safefree(unixified);
9242 if (!decc_efs_case_preserve) {
9243 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9244 if (_tolower(*cp1) != _tolower(*cp2)) break;
9246 segdirs = dirs - totells; /* Min # of dirs we must have left */
9247 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9248 if (*cp1 == '\0' && *cp2 == '/') {
9249 memmove(fspec,cp2+1,end - cp2);
9251 PerlMem_free(unixified);
9252 PerlMem_free(unixwild);
9253 PerlMem_free(lcres);
9256 /* Nope -- stick with lcfront from above and keep going. */
9259 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9261 PerlMem_free(unixified);
9262 PerlMem_free(unixwild);
9263 PerlMem_free(lcres);
9268 } /* end of trim_unixpath() */
9273 * VMS readdir() routines.
9274 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9276 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
9277 * Minor modifications to original routines.
9280 /* readdir may have been redefined by reentr.h, so make sure we get
9281 * the local version for what we do here.
9286 #if !defined(PERL_IMPLICIT_CONTEXT)
9287 # define readdir Perl_readdir
9289 # define readdir(a) Perl_readdir(aTHX_ a)
9292 /* Number of elements in vms_versions array */
9293 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
9296 * Open a directory, return a handle for later use.
9298 /*{{{ DIR *opendir(char*name) */
9300 Perl_opendir(pTHX_ const char *name)
9306 Newx(dir, VMS_MAXRSS, char);
9307 if (do_tovmspath(name,dir,0,NULL) == NULL) {
9311 /* Check access before stat; otherwise stat does not
9312 * accurately report whether it's a directory.
9314 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9315 /* cando_by_name has already set errno */
9319 if (flex_stat(dir,&sb) == -1) return NULL;
9320 if (!S_ISDIR(sb.st_mode)) {
9322 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
9325 /* Get memory for the handle, and the pattern. */
9327 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9329 /* Fill in the fields; mainly playing with the descriptor. */
9330 sprintf(dd->pattern, "%s*.*",dir);
9335 /* By saying we always want the result of readdir() in unix format, we
9336 * are really saying we want all the escapes removed. Otherwise the caller,
9337 * having no way to know whether it's already in VMS format, might send it
9338 * through tovmsspec again, thus double escaping.
9340 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9341 dd->pat.dsc$a_pointer = dd->pattern;
9342 dd->pat.dsc$w_length = strlen(dd->pattern);
9343 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9344 dd->pat.dsc$b_class = DSC$K_CLASS_S;
9345 #if defined(USE_ITHREADS)
9346 Newx(dd->mutex,1,perl_mutex);
9347 MUTEX_INIT( (perl_mutex *) dd->mutex );
9353 } /* end of opendir() */
9357 * Set the flag to indicate we want versions or not.
9359 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9361 vmsreaddirversions(DIR *dd, int flag)
9364 dd->flags |= PERL_VMSDIR_M_VERSIONS;
9366 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9371 * Free up an opened directory.
9373 /*{{{ void closedir(DIR *dd)*/
9375 Perl_closedir(DIR *dd)
9379 sts = lib$find_file_end(&dd->context);
9380 Safefree(dd->pattern);
9381 #if defined(USE_ITHREADS)
9382 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9383 Safefree(dd->mutex);
9390 * Collect all the version numbers for the current file.
9393 collectversions(pTHX_ DIR *dd)
9395 struct dsc$descriptor_s pat;
9396 struct dsc$descriptor_s res;
9398 char *p, *text, *buff;
9400 unsigned long context, tmpsts;
9402 /* Convenient shorthand. */
9405 /* Add the version wildcard, ignoring the "*.*" put on before */
9406 i = strlen(dd->pattern);
9407 Newx(text,i + e->d_namlen + 3,char);
9408 strcpy(text, dd->pattern);
9409 sprintf(&text[i - 3], "%s;*", e->d_name);
9411 /* Set up the pattern descriptor. */
9412 pat.dsc$a_pointer = text;
9413 pat.dsc$w_length = i + e->d_namlen - 1;
9414 pat.dsc$b_dtype = DSC$K_DTYPE_T;
9415 pat.dsc$b_class = DSC$K_CLASS_S;
9417 /* Set up result descriptor. */
9418 Newx(buff, VMS_MAXRSS, char);
9419 res.dsc$a_pointer = buff;
9420 res.dsc$w_length = VMS_MAXRSS - 1;
9421 res.dsc$b_dtype = DSC$K_DTYPE_T;
9422 res.dsc$b_class = DSC$K_CLASS_S;
9424 /* Read files, collecting versions. */
9425 for (context = 0, e->vms_verscount = 0;
9426 e->vms_verscount < VERSIZE(e);
9427 e->vms_verscount++) {
9429 unsigned long flags = 0;
9431 #ifdef VMS_LONGNAME_SUPPORT
9432 flags = LIB$M_FIL_LONG_NAMES;
9434 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9435 if (tmpsts == RMS$_NMF || context == 0) break;
9437 buff[VMS_MAXRSS - 1] = '\0';
9438 if ((p = strchr(buff, ';')))
9439 e->vms_versions[e->vms_verscount] = atoi(p + 1);
9441 e->vms_versions[e->vms_verscount] = -1;
9444 _ckvmssts(lib$find_file_end(&context));
9448 } /* end of collectversions() */
9451 * Read the next entry from the directory.
9453 /*{{{ struct dirent *readdir(DIR *dd)*/
9455 Perl_readdir(pTHX_ DIR *dd)
9457 struct dsc$descriptor_s res;
9459 unsigned long int tmpsts;
9461 unsigned long flags = 0;
9462 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9463 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9465 /* Set up result descriptor, and get next file. */
9466 Newx(buff, VMS_MAXRSS, char);
9467 res.dsc$a_pointer = buff;
9468 res.dsc$w_length = VMS_MAXRSS - 1;
9469 res.dsc$b_dtype = DSC$K_DTYPE_T;
9470 res.dsc$b_class = DSC$K_CLASS_S;
9472 #ifdef VMS_LONGNAME_SUPPORT
9473 flags = LIB$M_FIL_LONG_NAMES;
9476 tmpsts = lib$find_file
9477 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9478 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
9479 if (!(tmpsts & 1)) {
9480 set_vaxc_errno(tmpsts);
9483 set_errno(EACCES); break;
9485 set_errno(ENODEV); break;
9487 set_errno(ENOTDIR); break;
9488 case RMS$_FNF: case RMS$_DNF:
9489 set_errno(ENOENT); break;
9497 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9498 if (!decc_efs_case_preserve) {
9499 buff[VMS_MAXRSS - 1] = '\0';
9500 for (p = buff; *p; p++) *p = _tolower(*p);
9503 /* we don't want to force to lowercase, just null terminate */
9504 buff[res.dsc$w_length] = '\0';
9506 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
9509 /* Skip any directory component and just copy the name. */
9510 sts = vms_split_path
9525 /* Drop NULL extensions on UNIX file specification */
9526 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9527 (e_len == 1) && decc_readdir_dropdotnotype)) {
9532 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9533 dd->entry.d_name[n_len + e_len] = '\0';
9534 dd->entry.d_namlen = strlen(dd->entry.d_name);
9536 /* Convert the filename to UNIX format if needed */
9537 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9539 /* Translate the encoded characters. */
9540 /* Fixme: Unicode handling could result in embedded 0 characters */
9541 if (strchr(dd->entry.d_name, '^') != NULL) {
9544 p = dd->entry.d_name;
9547 int inchars_read, outchars_added;
9548 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9550 q += outchars_added;
9552 /* if outchars_added > 1, then this is a wide file specification */
9553 /* Wide file specifications need to be passed in Perl */
9554 /* counted strings apparently with a Unicode flag */
9557 strcpy(dd->entry.d_name, new_name);
9558 dd->entry.d_namlen = strlen(dd->entry.d_name);
9562 dd->entry.vms_verscount = 0;
9563 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9567 } /* end of readdir() */
9571 * Read the next entry from the directory -- thread-safe version.
9573 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9575 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9579 MUTEX_LOCK( (perl_mutex *) dd->mutex );
9581 entry = readdir(dd);
9583 retval = ( *result == NULL ? errno : 0 );
9585 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9589 } /* end of readdir_r() */
9593 * Return something that can be used in a seekdir later.
9595 /*{{{ long telldir(DIR *dd)*/
9597 Perl_telldir(DIR *dd)
9604 * Return to a spot where we used to be. Brute force.
9606 /*{{{ void seekdir(DIR *dd,long count)*/
9608 Perl_seekdir(pTHX_ DIR *dd, long count)
9612 /* If we haven't done anything yet... */
9616 /* Remember some state, and clear it. */
9617 old_flags = dd->flags;
9618 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9619 _ckvmssts(lib$find_file_end(&dd->context));
9622 /* The increment is in readdir(). */
9623 for (dd->count = 0; dd->count < count; )
9626 dd->flags = old_flags;
9628 } /* end of seekdir() */
9631 /* VMS subprocess management
9633 * my_vfork() - just a vfork(), after setting a flag to record that
9634 * the current script is trying a Unix-style fork/exec.
9636 * vms_do_aexec() and vms_do_exec() are called in response to the
9637 * perl 'exec' function. If this follows a vfork call, then they
9638 * call out the regular perl routines in doio.c which do an
9639 * execvp (for those who really want to try this under VMS).
9640 * Otherwise, they do exactly what the perl docs say exec should
9641 * do - terminate the current script and invoke a new command
9642 * (See below for notes on command syntax.)
9644 * do_aspawn() and do_spawn() implement the VMS side of the perl
9645 * 'system' function.
9647 * Note on command arguments to perl 'exec' and 'system': When handled
9648 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9649 * are concatenated to form a DCL command string. If the first non-numeric
9650 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
9651 * the command string is handed off to DCL directly. Otherwise,
9652 * the first token of the command is taken as the filespec of an image
9653 * to run. The filespec is expanded using a default type of '.EXE' and
9654 * the process defaults for device, directory, etc., and if found, the resultant
9655 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9656 * the command string as parameters. This is perhaps a bit complicated,
9657 * but I hope it will form a happy medium between what VMS folks expect
9658 * from lib$spawn and what Unix folks expect from exec.
9661 static int vfork_called;
9663 /*{{{int my_vfork()*/
9674 vms_execfree(struct dsc$descriptor_s *vmscmd)
9677 if (vmscmd->dsc$a_pointer) {
9678 PerlMem_free(vmscmd->dsc$a_pointer);
9680 PerlMem_free(vmscmd);
9685 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9687 char *junk, *tmps = Nullch;
9688 register size_t cmdlen = 0;
9695 tmps = SvPV(really,rlen);
9702 for (idx++; idx <= sp; idx++) {
9704 junk = SvPVx(*idx,rlen);
9705 cmdlen += rlen ? rlen + 1 : 0;
9708 Newx(PL_Cmd, cmdlen+1, char);
9710 if (tmps && *tmps) {
9711 strcpy(PL_Cmd,tmps);
9714 else *PL_Cmd = '\0';
9715 while (++mark <= sp) {
9717 char *s = SvPVx(*mark,n_a);
9719 if (*PL_Cmd) strcat(PL_Cmd," ");
9725 } /* end of setup_argstr() */
9728 static unsigned long int
9729 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9730 struct dsc$descriptor_s **pvmscmd)
9732 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9733 char image_name[NAM$C_MAXRSS+1];
9734 char image_argv[NAM$C_MAXRSS+1];
9735 $DESCRIPTOR(defdsc,".EXE");
9736 $DESCRIPTOR(defdsc2,".");
9737 $DESCRIPTOR(resdsc,resspec);
9738 struct dsc$descriptor_s *vmscmd;
9739 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9740 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9741 register char *s, *rest, *cp, *wordbreak;
9746 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9747 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9749 /* Make a copy for modification */
9750 cmdlen = strlen(incmd);
9751 cmd = PerlMem_malloc(cmdlen+1);
9752 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9753 strncpy(cmd, incmd, cmdlen);
9758 vmscmd->dsc$a_pointer = NULL;
9759 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
9760 vmscmd->dsc$b_class = DSC$K_CLASS_S;
9761 vmscmd->dsc$w_length = 0;
9762 if (pvmscmd) *pvmscmd = vmscmd;
9764 if (suggest_quote) *suggest_quote = 0;
9766 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9768 return CLI$_BUFOVF; /* continuation lines currently unsupported */
9773 while (*s && isspace(*s)) s++;
9775 if (*s == '@' || *s == '$') {
9776 vmsspec[0] = *s; rest = s + 1;
9777 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9779 else { cp = vmsspec; rest = s; }
9780 if (*rest == '.' || *rest == '/') {
9783 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9784 rest++, cp2++) *cp2 = *rest;
9786 if (do_tovmsspec(resspec,cp,0,NULL)) {
9789 for (cp2 = vmsspec + strlen(vmsspec);
9790 *rest && cp2 - vmsspec < sizeof vmsspec;
9791 rest++, cp2++) *cp2 = *rest;
9796 /* Intuit whether verb (first word of cmd) is a DCL command:
9797 * - if first nonspace char is '@', it's a DCL indirection
9799 * - if verb contains a filespec separator, it's not a DCL command
9800 * - if it doesn't, caller tells us whether to default to a DCL
9801 * command, or to a local image unless told it's DCL (by leading '$')
9805 if (suggest_quote) *suggest_quote = 1;
9807 register char *filespec = strpbrk(s,":<[.;");
9808 rest = wordbreak = strpbrk(s," \"\t/");
9809 if (!wordbreak) wordbreak = s + strlen(s);
9810 if (*s == '$') check_img = 0;
9811 if (filespec && (filespec < wordbreak)) isdcl = 0;
9812 else isdcl = !check_img;
9817 imgdsc.dsc$a_pointer = s;
9818 imgdsc.dsc$w_length = wordbreak - s;
9819 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9821 _ckvmssts(lib$find_file_end(&cxt));
9822 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9823 if (!(retsts & 1) && *s == '$') {
9824 _ckvmssts(lib$find_file_end(&cxt));
9825 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9826 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9828 _ckvmssts(lib$find_file_end(&cxt));
9829 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9833 _ckvmssts(lib$find_file_end(&cxt));
9838 while (*s && !isspace(*s)) s++;
9841 /* check that it's really not DCL with no file extension */
9842 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9844 char b[256] = {0,0,0,0};
9845 read(fileno(fp), b, 256);
9846 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9850 /* Check for script */
9852 if ((b[0] == '#') && (b[1] == '!'))
9854 #ifdef ALTERNATE_SHEBANG
9856 shebang_len = strlen(ALTERNATE_SHEBANG);
9857 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9859 perlstr = strstr("perl",b);
9860 if (perlstr == NULL)
9868 if (shebang_len > 0) {
9871 char tmpspec[NAM$C_MAXRSS + 1];
9874 /* Image is following after white space */
9875 /*--------------------------------------*/
9876 while (isprint(b[i]) && isspace(b[i]))
9880 while (isprint(b[i]) && !isspace(b[i])) {
9881 tmpspec[j++] = b[i++];
9882 if (j >= NAM$C_MAXRSS)
9887 /* There may be some default parameters to the image */
9888 /*---------------------------------------------------*/
9890 while (isprint(b[i])) {
9891 image_argv[j++] = b[i++];
9892 if (j >= NAM$C_MAXRSS)
9895 while ((j > 0) && !isprint(image_argv[j-1]))
9899 /* It will need to be converted to VMS format and validated */
9900 if (tmpspec[0] != '\0') {
9903 /* Try to find the exact program requested to be run */
9904 /*---------------------------------------------------*/
9905 iname = do_rmsexpand
9906 (tmpspec, image_name, 0, ".exe",
9907 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9908 if (iname != NULL) {
9909 if (cando_by_name_int
9910 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9911 /* MCR prefix needed */
9915 /* Try again with a null type */
9916 /*----------------------------*/
9917 iname = do_rmsexpand
9918 (tmpspec, image_name, 0, ".",
9919 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9920 if (iname != NULL) {
9921 if (cando_by_name_int
9922 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9923 /* MCR prefix needed */
9929 /* Did we find the image to run the script? */
9930 /*------------------------------------------*/
9934 /* Assume DCL or foreign command exists */
9935 /*--------------------------------------*/
9936 tchr = strrchr(tmpspec, '/');
9943 strcpy(image_name, tchr);
9951 if (check_img && isdcl) return RMS$_FNF;
9953 if (cando_by_name(S_IXUSR,0,resspec)) {
9954 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9955 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9957 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9958 if (image_name[0] != 0) {
9959 strcat(vmscmd->dsc$a_pointer, image_name);
9960 strcat(vmscmd->dsc$a_pointer, " ");
9962 } else if (image_name[0] != 0) {
9963 strcpy(vmscmd->dsc$a_pointer, image_name);
9964 strcat(vmscmd->dsc$a_pointer, " ");
9966 strcpy(vmscmd->dsc$a_pointer,"@");
9968 if (suggest_quote) *suggest_quote = 1;
9970 /* If there is an image name, use original command */
9971 if (image_name[0] == 0)
9972 strcat(vmscmd->dsc$a_pointer,resspec);
9975 while (*rest && isspace(*rest)) rest++;
9978 if (image_argv[0] != 0) {
9979 strcat(vmscmd->dsc$a_pointer,image_argv);
9980 strcat(vmscmd->dsc$a_pointer, " ");
9986 rest_len = strlen(rest);
9987 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9988 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9989 strcat(vmscmd->dsc$a_pointer,rest);
9991 retsts = CLI$_BUFOVF;
9993 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9995 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10001 /* It's either a DCL command or we couldn't find a suitable image */
10002 vmscmd->dsc$w_length = strlen(cmd);
10004 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10005 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10006 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10010 /* check if it's a symbol (for quoting purposes) */
10011 if (suggest_quote && !*suggest_quote) {
10013 char equiv[LNM$C_NAMLENGTH];
10014 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10015 eqvdsc.dsc$a_pointer = equiv;
10017 iss = lib$get_symbol(vmscmd,&eqvdsc);
10018 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10020 if (!(retsts & 1)) {
10021 /* just hand off status values likely to be due to user error */
10022 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10023 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10024 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10025 else { _ckvmssts(retsts); }
10028 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10030 } /* end of setup_cmddsc() */
10033 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10035 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10041 if (vfork_called) { /* this follows a vfork - act Unixish */
10043 if (vfork_called < 0) {
10044 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10047 else return do_aexec(really,mark,sp);
10049 /* no vfork - act VMSish */
10050 cmd = setup_argstr(aTHX_ really,mark,sp);
10051 exec_sts = vms_do_exec(cmd);
10052 Safefree(cmd); /* Clean up from setup_argstr() */
10057 } /* end of vms_do_aexec() */
10060 /* {{{bool vms_do_exec(char *cmd) */
10062 Perl_vms_do_exec(pTHX_ const char *cmd)
10064 struct dsc$descriptor_s *vmscmd;
10066 if (vfork_called) { /* this follows a vfork - act Unixish */
10068 if (vfork_called < 0) {
10069 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10072 else return do_exec(cmd);
10075 { /* no vfork - act VMSish */
10076 unsigned long int retsts;
10079 TAINT_PROPER("exec");
10080 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10081 retsts = lib$do_command(vmscmd);
10084 case RMS$_FNF: case RMS$_DNF:
10085 set_errno(ENOENT); break;
10087 set_errno(ENOTDIR); break;
10089 set_errno(ENODEV); break;
10091 set_errno(EACCES); break;
10093 set_errno(EINVAL); break;
10094 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10095 set_errno(E2BIG); break;
10096 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10097 _ckvmssts(retsts); /* fall through */
10098 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10099 set_errno(EVMSERR);
10101 set_vaxc_errno(retsts);
10102 if (ckWARN(WARN_EXEC)) {
10103 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10104 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10106 vms_execfree(vmscmd);
10111 } /* end of vms_do_exec() */
10114 unsigned long int Perl_do_spawn(pTHX_ const char *);
10115 unsigned long int do_spawn2(pTHX_ const char *, int);
10117 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
10119 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
10121 unsigned long int sts;
10127 /* We'll copy the (undocumented?) Win32 behavior and allow a
10128 * numeric first argument. But the only value we'll support
10129 * through do_aspawn is a value of 1, which means spawn without
10130 * waiting for completion -- other values are ignored.
10132 if (SvNIOKp(*((SV**)mark+1)) && !SvPOKp(*((SV**)mark+1))) {
10134 flags = SvIVx(*(SV**)mark);
10137 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
10138 flags = CLI$M_NOWAIT;
10142 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
10143 sts = do_spawn2(aTHX_ cmd, flags);
10144 /* pp_sys will clean up cmd */
10148 } /* end of do_aspawn() */
10152 /* {{{unsigned long int do_spawn(char *cmd) */
10154 Perl_do_spawn(pTHX_ const char *cmd)
10156 return do_spawn2(aTHX_ cmd, 0);
10160 /* {{{unsigned long int do_spawn2(char *cmd) */
10162 do_spawn2(pTHX_ const char *cmd, int flags)
10164 unsigned long int sts, substs;
10166 /* The caller of this routine expects to Safefree(PL_Cmd) */
10167 Newx(PL_Cmd,10,char);
10170 TAINT_PROPER("spawn");
10171 if (!cmd || !*cmd) {
10172 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10175 case RMS$_FNF: case RMS$_DNF:
10176 set_errno(ENOENT); break;
10178 set_errno(ENOTDIR); break;
10180 set_errno(ENODEV); break;
10182 set_errno(EACCES); break;
10184 set_errno(EINVAL); break;
10185 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10186 set_errno(E2BIG); break;
10187 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10188 _ckvmssts(sts); /* fall through */
10189 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10190 set_errno(EVMSERR);
10192 set_vaxc_errno(sts);
10193 if (ckWARN(WARN_EXEC)) {
10194 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10203 if (flags & CLI$M_NOWAIT)
10206 strcpy(mode, "nW");
10208 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10211 /* sts will be the pid in the nowait case */
10214 } /* end of do_spawn2() */
10218 static unsigned int *sockflags, sockflagsize;
10221 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10222 * routines found in some versions of the CRTL can't deal with sockets.
10223 * We don't shim the other file open routines since a socket isn't
10224 * likely to be opened by a name.
10226 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10227 FILE *my_fdopen(int fd, const char *mode)
10229 FILE *fp = fdopen(fd, mode);
10232 unsigned int fdoff = fd / sizeof(unsigned int);
10233 Stat_t sbuf; /* native stat; we don't need flex_stat */
10234 if (!sockflagsize || fdoff > sockflagsize) {
10235 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
10236 else Newx (sockflags,fdoff+2,unsigned int);
10237 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10238 sockflagsize = fdoff + 2;
10240 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10241 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10250 * Clear the corresponding bit when the (possibly) socket stream is closed.
10251 * There still a small hole: we miss an implicit close which might occur
10252 * via freopen(). >> Todo
10254 /*{{{ int my_fclose(FILE *fp)*/
10255 int my_fclose(FILE *fp) {
10257 unsigned int fd = fileno(fp);
10258 unsigned int fdoff = fd / sizeof(unsigned int);
10260 if (sockflagsize && fdoff <= sockflagsize)
10261 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10269 * A simple fwrite replacement which outputs itmsz*nitm chars without
10270 * introducing record boundaries every itmsz chars.
10271 * We are using fputs, which depends on a terminating null. We may
10272 * well be writing binary data, so we need to accommodate not only
10273 * data with nulls sprinkled in the middle but also data with no null
10276 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10278 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10280 register char *cp, *end, *cpd, *data;
10281 register unsigned int fd = fileno(dest);
10282 register unsigned int fdoff = fd / sizeof(unsigned int);
10284 int bufsize = itmsz * nitm + 1;
10286 if (fdoff < sockflagsize &&
10287 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10288 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10292 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10293 memcpy( data, src, itmsz*nitm );
10294 data[itmsz*nitm] = '\0';
10296 end = data + itmsz * nitm;
10297 retval = (int) nitm; /* on success return # items written */
10300 while (cpd <= end) {
10301 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10302 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10304 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10308 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10311 } /* end of my_fwrite() */
10314 /*{{{ int my_flush(FILE *fp)*/
10316 Perl_my_flush(pTHX_ FILE *fp)
10319 if ((res = fflush(fp)) == 0 && fp) {
10320 #ifdef VMS_DO_SOCKETS
10322 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
10324 res = fsync(fileno(fp));
10327 * If the flush succeeded but set end-of-file, we need to clear
10328 * the error because our caller may check ferror(). BTW, this
10329 * probably means we just flushed an empty file.
10331 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10338 * Here are replacements for the following Unix routines in the VMS environment:
10339 * getpwuid Get information for a particular UIC or UID
10340 * getpwnam Get information for a named user
10341 * getpwent Get information for each user in the rights database
10342 * setpwent Reset search to the start of the rights database
10343 * endpwent Finish searching for users in the rights database
10345 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10346 * (defined in pwd.h), which contains the following fields:-
10348 * char *pw_name; Username (in lower case)
10349 * char *pw_passwd; Hashed password
10350 * unsigned int pw_uid; UIC
10351 * unsigned int pw_gid; UIC group number
10352 * char *pw_unixdir; Default device/directory (VMS-style)
10353 * char *pw_gecos; Owner name
10354 * char *pw_dir; Default device/directory (Unix-style)
10355 * char *pw_shell; Default CLI name (eg. DCL)
10357 * If the specified user does not exist, getpwuid and getpwnam return NULL.
10359 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10360 * not the UIC member number (eg. what's returned by getuid()),
10361 * getpwuid() can accept either as input (if uid is specified, the caller's
10362 * UIC group is used), though it won't recognise gid=0.
10364 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10365 * information about other users in your group or in other groups, respectively.
10366 * If the required privilege is not available, then these routines fill only
10367 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10370 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10373 /* sizes of various UAF record fields */
10374 #define UAI$S_USERNAME 12
10375 #define UAI$S_IDENT 31
10376 #define UAI$S_OWNER 31
10377 #define UAI$S_DEFDEV 31
10378 #define UAI$S_DEFDIR 63
10379 #define UAI$S_DEFCLI 31
10380 #define UAI$S_PWD 8
10382 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
10383 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10384 (uic).uic$v_group != UIC$K_WILD_GROUP)
10386 static char __empty[]= "";
10387 static struct passwd __passwd_empty=
10388 {(char *) __empty, (char *) __empty, 0, 0,
10389 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10390 static int contxt= 0;
10391 static struct passwd __pwdcache;
10392 static char __pw_namecache[UAI$S_IDENT+1];
10395 * This routine does most of the work extracting the user information.
10397 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10400 unsigned char length;
10401 char pw_gecos[UAI$S_OWNER+1];
10403 static union uicdef uic;
10405 unsigned char length;
10406 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10409 unsigned char length;
10410 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10413 unsigned char length;
10414 char pw_shell[UAI$S_DEFCLI+1];
10416 static char pw_passwd[UAI$S_PWD+1];
10418 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10419 struct dsc$descriptor_s name_desc;
10420 unsigned long int sts;
10422 static struct itmlst_3 itmlst[]= {
10423 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
10424 {sizeof(uic), UAI$_UIC, &uic, &luic},
10425 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
10426 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
10427 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
10428 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
10429 {0, 0, NULL, NULL}};
10431 name_desc.dsc$w_length= strlen(name);
10432 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10433 name_desc.dsc$b_class= DSC$K_CLASS_S;
10434 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10436 /* Note that sys$getuai returns many fields as counted strings. */
10437 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10438 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10439 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10441 else { _ckvmssts(sts); }
10442 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
10444 if ((int) owner.length < lowner) lowner= (int) owner.length;
10445 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10446 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10447 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10448 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10449 owner.pw_gecos[lowner]= '\0';
10450 defdev.pw_dir[ldefdev+ldefdir]= '\0';
10451 defcli.pw_shell[ldefcli]= '\0';
10452 if (valid_uic(uic)) {
10453 pwd->pw_uid= uic.uic$l_uic;
10454 pwd->pw_gid= uic.uic$v_group;
10457 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10458 pwd->pw_passwd= pw_passwd;
10459 pwd->pw_gecos= owner.pw_gecos;
10460 pwd->pw_dir= defdev.pw_dir;
10461 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10462 pwd->pw_shell= defcli.pw_shell;
10463 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10465 ldir= strlen(pwd->pw_unixdir) - 1;
10466 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10469 strcpy(pwd->pw_unixdir, pwd->pw_dir);
10470 if (!decc_efs_case_preserve)
10471 __mystrtolower(pwd->pw_unixdir);
10476 * Get information for a named user.
10478 /*{{{struct passwd *getpwnam(char *name)*/
10479 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10481 struct dsc$descriptor_s name_desc;
10483 unsigned long int status, sts;
10485 __pwdcache = __passwd_empty;
10486 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10487 /* We still may be able to determine pw_uid and pw_gid */
10488 name_desc.dsc$w_length= strlen(name);
10489 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10490 name_desc.dsc$b_class= DSC$K_CLASS_S;
10491 name_desc.dsc$a_pointer= (char *) name;
10492 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10493 __pwdcache.pw_uid= uic.uic$l_uic;
10494 __pwdcache.pw_gid= uic.uic$v_group;
10497 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10498 set_vaxc_errno(sts);
10499 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10502 else { _ckvmssts(sts); }
10505 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10506 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10507 __pwdcache.pw_name= __pw_namecache;
10508 return &__pwdcache;
10509 } /* end of my_getpwnam() */
10513 * Get information for a particular UIC or UID.
10514 * Called by my_getpwent with uid=-1 to list all users.
10516 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10517 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10519 const $DESCRIPTOR(name_desc,__pw_namecache);
10520 unsigned short lname;
10522 unsigned long int status;
10524 if (uid == (unsigned int) -1) {
10526 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10527 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10528 set_vaxc_errno(status);
10529 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10533 else { _ckvmssts(status); }
10534 } while (!valid_uic (uic));
10537 uic.uic$l_uic= uid;
10538 if (!uic.uic$v_group)
10539 uic.uic$v_group= PerlProc_getgid();
10540 if (valid_uic(uic))
10541 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10542 else status = SS$_IVIDENT;
10543 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10544 status == RMS$_PRV) {
10545 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10548 else { _ckvmssts(status); }
10550 __pw_namecache[lname]= '\0';
10551 __mystrtolower(__pw_namecache);
10553 __pwdcache = __passwd_empty;
10554 __pwdcache.pw_name = __pw_namecache;
10556 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10557 The identifier's value is usually the UIC, but it doesn't have to be,
10558 so if we can, we let fillpasswd update this. */
10559 __pwdcache.pw_uid = uic.uic$l_uic;
10560 __pwdcache.pw_gid = uic.uic$v_group;
10562 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10563 return &__pwdcache;
10565 } /* end of my_getpwuid() */
10569 * Get information for next user.
10571 /*{{{struct passwd *my_getpwent()*/
10572 struct passwd *Perl_my_getpwent(pTHX)
10574 return (my_getpwuid((unsigned int) -1));
10579 * Finish searching rights database for users.
10581 /*{{{void my_endpwent()*/
10582 void Perl_my_endpwent(pTHX)
10585 _ckvmssts(sys$finish_rdb(&contxt));
10591 #ifdef HOMEGROWN_POSIX_SIGNALS
10592 /* Signal handling routines, pulled into the core from POSIX.xs.
10594 * We need these for threads, so they've been rolled into the core,
10595 * rather than left in POSIX.xs.
10597 * (DRS, Oct 23, 1997)
10600 /* sigset_t is atomic under VMS, so these routines are easy */
10601 /*{{{int my_sigemptyset(sigset_t *) */
10602 int my_sigemptyset(sigset_t *set) {
10603 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10604 *set = 0; return 0;
10609 /*{{{int my_sigfillset(sigset_t *)*/
10610 int my_sigfillset(sigset_t *set) {
10612 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10613 for (i = 0; i < NSIG; i++) *set |= (1 << i);
10619 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10620 int my_sigaddset(sigset_t *set, int sig) {
10621 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10622 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10623 *set |= (1 << (sig - 1));
10629 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10630 int my_sigdelset(sigset_t *set, int sig) {
10631 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10632 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10633 *set &= ~(1 << (sig - 1));
10639 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10640 int my_sigismember(sigset_t *set, int sig) {
10641 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10642 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10643 return *set & (1 << (sig - 1));
10648 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10649 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10652 /* If set and oset are both null, then things are badly wrong. Bail out. */
10653 if ((oset == NULL) && (set == NULL)) {
10654 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10658 /* If set's null, then we're just handling a fetch. */
10660 tempmask = sigblock(0);
10665 tempmask = sigsetmask(*set);
10668 tempmask = sigblock(*set);
10671 tempmask = sigblock(0);
10672 sigsetmask(*oset & ~tempmask);
10675 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10680 /* Did they pass us an oset? If so, stick our holding mask into it */
10687 #endif /* HOMEGROWN_POSIX_SIGNALS */
10690 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10691 * my_utime(), and flex_stat(), all of which operate on UTC unless
10692 * VMSISH_TIMES is true.
10694 /* method used to handle UTC conversions:
10695 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
10697 static int gmtime_emulation_type;
10698 /* number of secs to add to UTC POSIX-style time to get local time */
10699 static long int utc_offset_secs;
10701 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10702 * in vmsish.h. #undef them here so we can call the CRTL routines
10711 * DEC C previous to 6.0 corrupts the behavior of the /prefix
10712 * qualifier with the extern prefix pragma. This provisional
10713 * hack circumvents this prefix pragma problem in previous
10716 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10717 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10718 # pragma __extern_prefix save
10719 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
10720 # define gmtime decc$__utctz_gmtime
10721 # define localtime decc$__utctz_localtime
10722 # define time decc$__utc_time
10723 # pragma __extern_prefix restore
10725 struct tm *gmtime(), *localtime();
10731 static time_t toutc_dst(time_t loc) {
10734 if ((rsltmp = localtime(&loc)) == NULL) return -1;
10735 loc -= utc_offset_secs;
10736 if (rsltmp->tm_isdst) loc -= 3600;
10739 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10740 ((gmtime_emulation_type || my_time(NULL)), \
10741 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10742 ((secs) - utc_offset_secs))))
10744 static time_t toloc_dst(time_t utc) {
10747 utc += utc_offset_secs;
10748 if ((rsltmp = localtime(&utc)) == NULL) return -1;
10749 if (rsltmp->tm_isdst) utc += 3600;
10752 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10753 ((gmtime_emulation_type || my_time(NULL)), \
10754 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10755 ((secs) + utc_offset_secs))))
10757 #ifndef RTL_USES_UTC
10760 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
10761 DST starts on 1st sun of april at 02:00 std time
10762 ends on last sun of october at 02:00 dst time
10763 see the UCX management command reference, SET CONFIG TIMEZONE
10764 for formatting info.
10766 No, it's not as general as it should be, but then again, NOTHING
10767 will handle UK times in a sensible way.
10772 parse the DST start/end info:
10773 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10777 tz_parse_startend(char *s, struct tm *w, int *past)
10779 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10780 int ly, dozjd, d, m, n, hour, min, sec, j, k;
10785 if (!past) return 0;
10788 if (w->tm_year % 4 == 0) ly = 1;
10789 if (w->tm_year % 100 == 0) ly = 0;
10790 if (w->tm_year+1900 % 400 == 0) ly = 1;
10793 dozjd = isdigit(*s);
10794 if (*s == 'J' || *s == 'j' || dozjd) {
10795 if (!dozjd && !isdigit(*++s)) return 0;
10798 d = d*10 + *s++ - '0';
10800 d = d*10 + *s++ - '0';
10803 if (d == 0) return 0;
10804 if (d > 366) return 0;
10806 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
10809 } else if (*s == 'M' || *s == 'm') {
10810 if (!isdigit(*++s)) return 0;
10812 if (isdigit(*s)) m = 10*m + *s++ - '0';
10813 if (*s != '.') return 0;
10814 if (!isdigit(*++s)) return 0;
10816 if (n < 1 || n > 5) return 0;
10817 if (*s != '.') return 0;
10818 if (!isdigit(*++s)) return 0;
10820 if (d > 6) return 0;
10824 if (!isdigit(*++s)) return 0;
10826 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10828 if (!isdigit(*++s)) return 0;
10830 if (isdigit(*s)) min = 10*min + *s++ - '0';
10832 if (!isdigit(*++s)) return 0;
10834 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10844 if (w->tm_yday < d) goto before;
10845 if (w->tm_yday > d) goto after;
10847 if (w->tm_mon+1 < m) goto before;
10848 if (w->tm_mon+1 > m) goto after;
10850 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
10851 k = d - j; /* mday of first d */
10852 if (k <= 0) k += 7;
10853 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
10854 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10855 if (w->tm_mday < k) goto before;
10856 if (w->tm_mday > k) goto after;
10859 if (w->tm_hour < hour) goto before;
10860 if (w->tm_hour > hour) goto after;
10861 if (w->tm_min < min) goto before;
10862 if (w->tm_min > min) goto after;
10863 if (w->tm_sec < sec) goto before;
10877 /* parse the offset: (+|-)hh[:mm[:ss]] */
10880 tz_parse_offset(char *s, int *offset)
10882 int hour = 0, min = 0, sec = 0;
10885 if (!offset) return 0;
10887 if (*s == '-') {neg++; s++;}
10888 if (*s == '+') s++;
10889 if (!isdigit(*s)) return 0;
10891 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10892 if (hour > 24) return 0;
10894 if (!isdigit(*++s)) return 0;
10896 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10897 if (min > 59) return 0;
10899 if (!isdigit(*++s)) return 0;
10901 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10902 if (sec > 59) return 0;
10906 *offset = (hour*60+min)*60 + sec;
10907 if (neg) *offset = -*offset;
10912 input time is w, whatever type of time the CRTL localtime() uses.
10913 sets dst, the zone, and the gmtoff (seconds)
10915 caches the value of TZ and UCX$TZ env variables; note that
10916 my_setenv looks for these and sets a flag if they're changed
10919 We have to watch out for the "australian" case (dst starts in
10920 october, ends in april)...flagged by "reverse" and checked by
10921 scanning through the months of the previous year.
10926 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10931 char *dstzone, *tz, *s_start, *s_end;
10932 int std_off, dst_off, isdst;
10933 int y, dststart, dstend;
10934 static char envtz[1025]; /* longer than any logical, symbol, ... */
10935 static char ucxtz[1025];
10936 static char reversed = 0;
10942 reversed = -1; /* flag need to check */
10943 envtz[0] = ucxtz[0] = '\0';
10944 tz = my_getenv("TZ",0);
10945 if (tz) strcpy(envtz, tz);
10946 tz = my_getenv("UCX$TZ",0);
10947 if (tz) strcpy(ucxtz, tz);
10948 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
10951 if (!*tz) tz = ucxtz;
10954 while (isalpha(*s)) s++;
10955 s = tz_parse_offset(s, &std_off);
10957 if (!*s) { /* no DST, hurray we're done! */
10963 while (isalpha(*s)) s++;
10964 s2 = tz_parse_offset(s, &dst_off);
10968 dst_off = std_off - 3600;
10971 if (!*s) { /* default dst start/end?? */
10972 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
10973 s = strchr(ucxtz,',');
10975 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
10977 if (*s != ',') return 0;
10980 when = _toutc(when); /* convert to utc */
10981 when = when - std_off; /* convert to pseudolocal time*/
10983 w2 = localtime(&when);
10986 s = tz_parse_startend(s_start,w2,&dststart);
10988 if (*s != ',') return 0;
10991 when = _toutc(when); /* convert to utc */
10992 when = when - dst_off; /* convert to pseudolocal time*/
10993 w2 = localtime(&when);
10994 if (w2->tm_year != y) { /* spans a year, just check one time */
10995 when += dst_off - std_off;
10996 w2 = localtime(&when);
10999 s = tz_parse_startend(s_end,w2,&dstend);
11002 if (reversed == -1) { /* need to check if start later than end */
11006 if (when < 2*365*86400) {
11007 when += 2*365*86400;
11011 w2 =localtime(&when);
11012 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
11014 for (j = 0; j < 12; j++) {
11015 w2 =localtime(&when);
11016 tz_parse_startend(s_start,w2,&ds);
11017 tz_parse_startend(s_end,w2,&de);
11018 if (ds != de) break;
11022 if (de && !ds) reversed = 1;
11025 isdst = dststart && !dstend;
11026 if (reversed) isdst = dststart || !dstend;
11029 if (dst) *dst = isdst;
11030 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11031 if (isdst) tz = dstzone;
11033 while(isalpha(*tz)) *zone++ = *tz++;
11039 #endif /* !RTL_USES_UTC */
11041 /* my_time(), my_localtime(), my_gmtime()
11042 * By default traffic in UTC time values, using CRTL gmtime() or
11043 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11044 * Note: We need to use these functions even when the CRTL has working
11045 * UTC support, since they also handle C<use vmsish qw(times);>
11047 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
11048 * Modified by Charles Bailey <bailey@newman.upenn.edu>
11051 /*{{{time_t my_time(time_t *timep)*/
11052 time_t Perl_my_time(pTHX_ time_t *timep)
11057 if (gmtime_emulation_type == 0) {
11059 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11060 /* results of calls to gmtime() and localtime() */
11061 /* for same &base */
11063 gmtime_emulation_type++;
11064 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11065 char off[LNM$C_NAMLENGTH+1];;
11067 gmtime_emulation_type++;
11068 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11069 gmtime_emulation_type++;
11070 utc_offset_secs = 0;
11071 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11073 else { utc_offset_secs = atol(off); }
11075 else { /* We've got a working gmtime() */
11076 struct tm gmt, local;
11079 tm_p = localtime(&base);
11081 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11082 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11083 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11084 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11089 # ifdef VMSISH_TIME
11090 # ifdef RTL_USES_UTC
11091 if (VMSISH_TIME) when = _toloc(when);
11093 if (!VMSISH_TIME) when = _toutc(when);
11096 if (timep != NULL) *timep = when;
11099 } /* end of my_time() */
11103 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11105 Perl_my_gmtime(pTHX_ const time_t *timep)
11111 if (timep == NULL) {
11112 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11115 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11118 # ifdef VMSISH_TIME
11119 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11121 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
11122 return gmtime(&when);
11124 /* CRTL localtime() wants local time as input, so does no tz correction */
11125 rsltmp = localtime(&when);
11126 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
11129 } /* end of my_gmtime() */
11133 /*{{{struct tm *my_localtime(const time_t *timep)*/
11135 Perl_my_localtime(pTHX_ const time_t *timep)
11137 time_t when, whenutc;
11141 if (timep == NULL) {
11142 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11145 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11146 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11149 # ifdef RTL_USES_UTC
11150 # ifdef VMSISH_TIME
11151 if (VMSISH_TIME) when = _toutc(when);
11153 /* CRTL localtime() wants UTC as input, does tz correction itself */
11154 return localtime(&when);
11156 # else /* !RTL_USES_UTC */
11158 # ifdef VMSISH_TIME
11159 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
11160 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
11163 #ifndef RTL_USES_UTC
11164 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
11165 when = whenutc - offset; /* pseudolocal time*/
11168 /* CRTL localtime() wants local time as input, so does no tz correction */
11169 rsltmp = localtime(&when);
11170 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11174 } /* end of my_localtime() */
11177 /* Reset definitions for later calls */
11178 #define gmtime(t) my_gmtime(t)
11179 #define localtime(t) my_localtime(t)
11180 #define time(t) my_time(t)
11183 /* my_utime - update modification/access time of a file
11185 * VMS 7.3 and later implementation
11186 * Only the UTC translation is home-grown. The rest is handled by the
11187 * CRTL utime(), which will take into account the relevant feature
11188 * logicals and ODS-5 volume characteristics for true access times.
11190 * pre VMS 7.3 implementation:
11191 * The calling sequence is identical to POSIX utime(), but under
11192 * VMS with ODS-2, only the modification time is changed; ODS-2 does
11193 * not maintain access times. Restrictions differ from the POSIX
11194 * definition in that the time can be changed as long as the
11195 * caller has permission to execute the necessary IO$_MODIFY $QIO;
11196 * no separate checks are made to insure that the caller is the
11197 * owner of the file or has special privs enabled.
11198 * Code here is based on Joe Meadows' FILE utility.
11202 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11203 * to VMS epoch (01-JAN-1858 00:00:00.00)
11204 * in 100 ns intervals.
11206 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11208 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11209 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11211 #if __CRTL_VER >= 70300000
11212 struct utimbuf utc_utimes, *utc_utimesp;
11214 if (utimes != NULL) {
11215 utc_utimes.actime = utimes->actime;
11216 utc_utimes.modtime = utimes->modtime;
11217 # ifdef VMSISH_TIME
11218 /* If input was local; convert to UTC for sys svc */
11220 utc_utimes.actime = _toutc(utimes->actime);
11221 utc_utimes.modtime = _toutc(utimes->modtime);
11224 utc_utimesp = &utc_utimes;
11227 utc_utimesp = NULL;
11230 return utime(file, utc_utimesp);
11232 #else /* __CRTL_VER < 70300000 */
11236 long int bintime[2], len = 2, lowbit, unixtime,
11237 secscale = 10000000; /* seconds --> 100 ns intervals */
11238 unsigned long int chan, iosb[2], retsts;
11239 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11240 struct FAB myfab = cc$rms_fab;
11241 struct NAM mynam = cc$rms_nam;
11242 #if defined (__DECC) && defined (__VAX)
11243 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11244 * at least through VMS V6.1, which causes a type-conversion warning.
11246 # pragma message save
11247 # pragma message disable cvtdiftypes
11249 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11250 struct fibdef myfib;
11251 #if defined (__DECC) && defined (__VAX)
11252 /* This should be right after the declaration of myatr, but due
11253 * to a bug in VAX DEC C, this takes effect a statement early.
11255 # pragma message restore
11257 /* cast ok for read only parameter */
11258 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11259 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11260 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11262 if (file == NULL || *file == '\0') {
11263 SETERRNO(ENOENT, LIB$_INVARG);
11267 /* Convert to VMS format ensuring that it will fit in 255 characters */
11268 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11269 SETERRNO(ENOENT, LIB$_INVARG);
11272 if (utimes != NULL) {
11273 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
11274 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11275 * Since time_t is unsigned long int, and lib$emul takes a signed long int
11276 * as input, we force the sign bit to be clear by shifting unixtime right
11277 * one bit, then multiplying by an extra factor of 2 in lib$emul().
11279 lowbit = (utimes->modtime & 1) ? secscale : 0;
11280 unixtime = (long int) utimes->modtime;
11281 # ifdef VMSISH_TIME
11282 /* If input was UTC; convert to local for sys svc */
11283 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11285 unixtime >>= 1; secscale <<= 1;
11286 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11287 if (!(retsts & 1)) {
11288 SETERRNO(EVMSERR, retsts);
11291 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11292 if (!(retsts & 1)) {
11293 SETERRNO(EVMSERR, retsts);
11298 /* Just get the current time in VMS format directly */
11299 retsts = sys$gettim(bintime);
11300 if (!(retsts & 1)) {
11301 SETERRNO(EVMSERR, retsts);
11306 myfab.fab$l_fna = vmsspec;
11307 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11308 myfab.fab$l_nam = &mynam;
11309 mynam.nam$l_esa = esa;
11310 mynam.nam$b_ess = (unsigned char) sizeof esa;
11311 mynam.nam$l_rsa = rsa;
11312 mynam.nam$b_rss = (unsigned char) sizeof rsa;
11313 if (decc_efs_case_preserve)
11314 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11316 /* Look for the file to be affected, letting RMS parse the file
11317 * specification for us as well. I have set errno using only
11318 * values documented in the utime() man page for VMS POSIX.
11320 retsts = sys$parse(&myfab,0,0);
11321 if (!(retsts & 1)) {
11322 set_vaxc_errno(retsts);
11323 if (retsts == RMS$_PRV) set_errno(EACCES);
11324 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11325 else set_errno(EVMSERR);
11328 retsts = sys$search(&myfab,0,0);
11329 if (!(retsts & 1)) {
11330 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11331 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11332 set_vaxc_errno(retsts);
11333 if (retsts == RMS$_PRV) set_errno(EACCES);
11334 else if (retsts == RMS$_FNF) set_errno(ENOENT);
11335 else set_errno(EVMSERR);
11339 devdsc.dsc$w_length = mynam.nam$b_dev;
11340 /* cast ok for read only parameter */
11341 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11343 retsts = sys$assign(&devdsc,&chan,0,0);
11344 if (!(retsts & 1)) {
11345 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11346 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11347 set_vaxc_errno(retsts);
11348 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
11349 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
11350 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
11351 else set_errno(EVMSERR);
11355 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11356 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11358 memset((void *) &myfib, 0, sizeof myfib);
11359 #if defined(__DECC) || defined(__DECCXX)
11360 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11361 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11362 /* This prevents the revision time of the file being reset to the current
11363 * time as a result of our IO$_MODIFY $QIO. */
11364 myfib.fib$l_acctl = FIB$M_NORECORD;
11366 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11367 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11368 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11370 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11371 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11372 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11373 _ckvmssts(sys$dassgn(chan));
11374 if (retsts & 1) retsts = iosb[0];
11375 if (!(retsts & 1)) {
11376 set_vaxc_errno(retsts);
11377 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11378 else set_errno(EVMSERR);
11384 #endif /* #if __CRTL_VER >= 70300000 */
11386 } /* end of my_utime() */
11390 * flex_stat, flex_lstat, flex_fstat
11391 * basic stat, but gets it right when asked to stat
11392 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11395 #ifndef _USE_STD_STAT
11396 /* encode_dev packs a VMS device name string into an integer to allow
11397 * simple comparisons. This can be used, for example, to check whether two
11398 * files are located on the same device, by comparing their encoded device
11399 * names. Even a string comparison would not do, because stat() reuses the
11400 * device name buffer for each call; so without encode_dev, it would be
11401 * necessary to save the buffer and use strcmp (this would mean a number of
11402 * changes to the standard Perl code, to say nothing of what a Perl script
11403 * would have to do.
11405 * The device lock id, if it exists, should be unique (unless perhaps compared
11406 * with lock ids transferred from other nodes). We have a lock id if the disk is
11407 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11408 * device names. Thus we use the lock id in preference, and only if that isn't
11409 * available, do we try to pack the device name into an integer (flagged by
11410 * the sign bit (LOCKID_MASK) being set).
11412 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11413 * name and its encoded form, but it seems very unlikely that we will find
11414 * two files on different disks that share the same encoded device names,
11415 * and even more remote that they will share the same file id (if the test
11416 * is to check for the same file).
11418 * A better method might be to use sys$device_scan on the first call, and to
11419 * search for the device, returning an index into the cached array.
11420 * The number returned would be more intelligible.
11421 * This is probably not worth it, and anyway would take quite a bit longer
11422 * on the first call.
11424 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
11425 static mydev_t encode_dev (pTHX_ const char *dev)
11428 unsigned long int f;
11433 if (!dev || !dev[0]) return 0;
11437 struct dsc$descriptor_s dev_desc;
11438 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11440 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11441 can try that first. */
11442 dev_desc.dsc$w_length = strlen (dev);
11443 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11444 dev_desc.dsc$b_class = DSC$K_CLASS_S;
11445 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
11446 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11447 if (!$VMS_STATUS_SUCCESS(status)) {
11449 case SS$_NOSUCHDEV:
11450 SETERRNO(ENODEV, status);
11456 if (lockid) return (lockid & ~LOCKID_MASK);
11460 /* Otherwise we try to encode the device name */
11464 for (q = dev + strlen(dev); q--; q >= dev) {
11469 else if (isalpha (toupper (*q)))
11470 c= toupper (*q) - 'A' + (char)10;
11472 continue; /* Skip '$'s */
11474 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11476 enc += f * (unsigned long int) c;
11478 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11480 } /* end of encode_dev() */
11481 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11482 device_no = encode_dev(aTHX_ devname)
11484 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11485 device_no = new_dev_no
11489 is_null_device(name)
11492 if (decc_bug_devnull != 0) {
11493 if (strncmp("/dev/null", name, 9) == 0)
11496 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11497 The underscore prefix, controller letter, and unit number are
11498 independently optional; for our purposes, the colon punctuation
11499 is not. The colon can be trailed by optional directory and/or
11500 filename, but two consecutive colons indicates a nodename rather
11501 than a device. [pr] */
11502 if (*name == '_') ++name;
11503 if (tolower(*name++) != 'n') return 0;
11504 if (tolower(*name++) != 'l') return 0;
11505 if (tolower(*name) == 'a') ++name;
11506 if (*name == '0') ++name;
11507 return (*name++ == ':') && (*name != ':');
11512 Perl_cando_by_name_int
11513 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11515 char usrname[L_cuserid];
11516 struct dsc$descriptor_s usrdsc =
11517 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11518 char *vmsname = NULL, *fileified = NULL;
11519 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11520 unsigned short int retlen, trnlnm_iter_count;
11521 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11522 union prvdef curprv;
11523 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11524 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11525 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11526 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11527 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11529 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11531 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11533 static int profile_context = -1;
11535 if (!fname || !*fname) return FALSE;
11537 /* Make sure we expand logical names, since sys$check_access doesn't */
11538 fileified = PerlMem_malloc(VMS_MAXRSS);
11539 if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11540 if (!strpbrk(fname,"/]>:")) {
11541 strcpy(fileified,fname);
11542 trnlnm_iter_count = 0;
11543 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11544 trnlnm_iter_count++;
11545 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11550 vmsname = PerlMem_malloc(VMS_MAXRSS);
11551 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11552 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11553 /* Don't know if already in VMS format, so make sure */
11554 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11555 PerlMem_free(fileified);
11556 PerlMem_free(vmsname);
11561 strcpy(vmsname,fname);
11564 /* sys$check_access needs a file spec, not a directory spec.
11565 * Don't use flex_stat here, as that depends on thread context
11566 * having been initialized, and we may get here during startup.
11569 retlen = namdsc.dsc$w_length = strlen(vmsname);
11570 if (vmsname[retlen-1] == ']'
11571 || vmsname[retlen-1] == '>'
11572 || vmsname[retlen-1] == ':'
11573 || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11575 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11576 PerlMem_free(fileified);
11577 PerlMem_free(vmsname);
11586 retlen = namdsc.dsc$w_length = strlen(fname);
11587 namdsc.dsc$a_pointer = (char *)fname;
11590 case S_IXUSR: case S_IXGRP: case S_IXOTH:
11591 access = ARM$M_EXECUTE;
11592 flags = CHP$M_READ;
11594 case S_IRUSR: case S_IRGRP: case S_IROTH:
11595 access = ARM$M_READ;
11596 flags = CHP$M_READ | CHP$M_USEREADALL;
11598 case S_IWUSR: case S_IWGRP: case S_IWOTH:
11599 access = ARM$M_WRITE;
11600 flags = CHP$M_READ | CHP$M_WRITE;
11602 case S_IDUSR: case S_IDGRP: case S_IDOTH:
11603 access = ARM$M_DELETE;
11604 flags = CHP$M_READ | CHP$M_WRITE;
11607 if (fileified != NULL)
11608 PerlMem_free(fileified);
11609 if (vmsname != NULL)
11610 PerlMem_free(vmsname);
11614 /* Before we call $check_access, create a user profile with the current
11615 * process privs since otherwise it just uses the default privs from the
11616 * UAF and might give false positives or negatives. This only works on
11617 * VMS versions v6.0 and later since that's when sys$create_user_profile
11618 * became available.
11621 /* get current process privs and username */
11622 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11623 _ckvmssts(iosb[0]);
11625 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11627 /* find out the space required for the profile */
11628 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11629 &usrprodsc.dsc$w_length,&profile_context));
11631 /* allocate space for the profile and get it filled in */
11632 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11633 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11634 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11635 &usrprodsc.dsc$w_length,&profile_context));
11637 /* use the profile to check access to the file; free profile & analyze results */
11638 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11639 PerlMem_free(usrprodsc.dsc$a_pointer);
11640 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11644 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11648 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
11649 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11650 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11651 set_vaxc_errno(retsts);
11652 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11653 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11654 else set_errno(ENOENT);
11655 if (fileified != NULL)
11656 PerlMem_free(fileified);
11657 if (vmsname != NULL)
11658 PerlMem_free(vmsname);
11661 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11662 if (fileified != NULL)
11663 PerlMem_free(fileified);
11664 if (vmsname != NULL)
11665 PerlMem_free(vmsname);
11670 if (fileified != NULL)
11671 PerlMem_free(fileified);
11672 if (vmsname != NULL)
11673 PerlMem_free(vmsname);
11674 return FALSE; /* Should never get here */
11678 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
11679 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11680 * subset of the applicable information.
11683 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11685 return cando_by_name_int
11686 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11687 } /* end of cando() */
11691 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11693 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11695 return cando_by_name_int(bit, effective, fname, 0);
11697 } /* end of cando_by_name() */
11701 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11703 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11705 if (!fstat(fd,(stat_t *) statbufp)) {
11707 char *vms_filename;
11708 vms_filename = PerlMem_malloc(VMS_MAXRSS);
11709 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11711 /* Save name for cando by name in VMS format */
11712 cptr = getname(fd, vms_filename, 1);
11714 /* This should not happen, but just in case */
11715 if (cptr == NULL) {
11716 statbufp->st_devnam[0] = 0;
11719 /* Make sure that the saved name fits in 255 characters */
11720 cptr = do_rmsexpand
11722 statbufp->st_devnam,
11725 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11729 statbufp->st_devnam[0] = 0;
11731 PerlMem_free(vms_filename);
11733 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11735 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11737 # ifdef RTL_USES_UTC
11738 # ifdef VMSISH_TIME
11740 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11741 statbufp->st_atime = _toloc(statbufp->st_atime);
11742 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11746 # ifdef VMSISH_TIME
11747 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11751 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11752 statbufp->st_atime = _toutc(statbufp->st_atime);
11753 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11760 } /* end of flex_fstat() */
11763 #if !defined(__VAX) && __CRTL_VER >= 80200000
11771 #define lstat(_x, _y) stat(_x, _y)
11774 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11777 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11779 char fileified[VMS_MAXRSS];
11780 char temp_fspec[VMS_MAXRSS];
11783 int saved_errno, saved_vaxc_errno;
11785 if (!fspec) return retval;
11786 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11787 strcpy(temp_fspec, fspec);
11789 if (decc_bug_devnull != 0) {
11790 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11791 memset(statbufp,0,sizeof *statbufp);
11792 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11793 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11794 statbufp->st_uid = 0x00010001;
11795 statbufp->st_gid = 0x0001;
11796 time((time_t *)&statbufp->st_mtime);
11797 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11802 /* Try for a directory name first. If fspec contains a filename without
11803 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11804 * and sea:[wine.dark]water. exist, we prefer the directory here.
11805 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11806 * not sea:[wine.dark]., if the latter exists. If the intended target is
11807 * the file with null type, specify this by calling flex_stat() with
11808 * a '.' at the end of fspec.
11810 * If we are in Posix filespec mode, accept the filename as is.
11814 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11815 /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11816 * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11818 if (!decc_efs_charset)
11819 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11822 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11823 if (decc_posix_compliant_pathnames == 0) {
11825 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11826 if (lstat_flag == 0)
11827 retval = stat(fileified,(stat_t *) statbufp);
11829 retval = lstat(fileified,(stat_t *) statbufp);
11830 save_spec = fileified;
11833 if (lstat_flag == 0)
11834 retval = stat(temp_fspec,(stat_t *) statbufp);
11836 retval = lstat(temp_fspec,(stat_t *) statbufp);
11837 save_spec = temp_fspec;
11840 * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11841 * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11842 * and lstat was working correctly for the same file.
11843 * The only syntax that was working for stat was "foo:[bar]t.dir".
11845 * Other directories with the same syntax worked fine.
11846 * So work around the problem when it shows up here.
11849 int save_errno = errno;
11850 if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
11851 if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
11852 retval = stat(fileified, (stat_t *) statbufp);
11853 save_spec = fileified;
11856 /* Restore the errno value if third stat does not succeed */
11858 errno = save_errno;
11860 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11862 if (lstat_flag == 0)
11863 retval = stat(temp_fspec,(stat_t *) statbufp);
11865 retval = lstat(temp_fspec,(stat_t *) statbufp);
11866 save_spec = temp_fspec;
11870 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11871 /* As you were... */
11872 if (!decc_efs_charset)
11873 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11878 cptr = do_rmsexpand
11879 (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11881 statbufp->st_devnam[0] = 0;
11883 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11885 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11886 # ifdef RTL_USES_UTC
11887 # ifdef VMSISH_TIME
11889 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11890 statbufp->st_atime = _toloc(statbufp->st_atime);
11891 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11895 # ifdef VMSISH_TIME
11896 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11900 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11901 statbufp->st_atime = _toutc(statbufp->st_atime);
11902 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11906 /* If we were successful, leave errno where we found it */
11907 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11910 } /* end of flex_stat_int() */
11913 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11915 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11917 return flex_stat_int(fspec, statbufp, 0);
11921 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11923 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11925 return flex_stat_int(fspec, statbufp, 1);
11930 /*{{{char *my_getlogin()*/
11931 /* VMS cuserid == Unix getlogin, except calling sequence */
11935 static char user[L_cuserid];
11936 return cuserid(user);
11941 /* rmscopy - copy a file using VMS RMS routines
11943 * Copies contents and attributes of spec_in to spec_out, except owner
11944 * and protection information. Name and type of spec_in are used as
11945 * defaults for spec_out. The third parameter specifies whether rmscopy()
11946 * should try to propagate timestamps from the input file to the output file.
11947 * If it is less than 0, no timestamps are preserved. If it is 0, then
11948 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
11949 * propagated to the output file at creation iff the output file specification
11950 * did not contain an explicit name or type, and the revision date is always
11951 * updated at the end of the copy operation. If it is greater than 0, then
11952 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11953 * other than the revision date should be propagated, and bit 1 indicates
11954 * that the revision date should be propagated.
11956 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11958 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11959 * Incorporates, with permission, some code from EZCOPY by Tim Adye
11960 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
11961 * as part of the Perl standard distribution under the terms of the
11962 * GNU General Public License or the Perl Artistic License. Copies
11963 * of each may be found in the Perl standard distribution.
11965 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11967 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11969 char *vmsin, * vmsout, *esa, *esa_out,
11971 unsigned long int i, sts, sts2;
11973 struct FAB fab_in, fab_out;
11974 struct RAB rab_in, rab_out;
11975 rms_setup_nam(nam);
11976 rms_setup_nam(nam_out);
11977 struct XABDAT xabdat;
11978 struct XABFHC xabfhc;
11979 struct XABRDT xabrdt;
11980 struct XABSUM xabsum;
11982 vmsin = PerlMem_malloc(VMS_MAXRSS);
11983 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11984 vmsout = PerlMem_malloc(VMS_MAXRSS);
11985 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11986 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11987 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11988 PerlMem_free(vmsin);
11989 PerlMem_free(vmsout);
11990 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11994 esa = PerlMem_malloc(VMS_MAXRSS);
11995 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11996 fab_in = cc$rms_fab;
11997 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11998 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11999 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12000 fab_in.fab$l_fop = FAB$M_SQO;
12001 rms_bind_fab_nam(fab_in, nam);
12002 fab_in.fab$l_xab = (void *) &xabdat;
12004 rsa = PerlMem_malloc(VMS_MAXRSS);
12005 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
12006 rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
12007 rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
12008 rms_nam_esl(nam) = 0;
12009 rms_nam_rsl(nam) = 0;
12010 rms_nam_esll(nam) = 0;
12011 rms_nam_rsll(nam) = 0;
12012 #ifdef NAM$M_NO_SHORT_UPCASE
12013 if (decc_efs_case_preserve)
12014 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12017 xabdat = cc$rms_xabdat; /* To get creation date */
12018 xabdat.xab$l_nxt = (void *) &xabfhc;
12020 xabfhc = cc$rms_xabfhc; /* To get record length */
12021 xabfhc.xab$l_nxt = (void *) &xabsum;
12023 xabsum = cc$rms_xabsum; /* To get key and area information */
12025 if (!((sts = sys$open(&fab_in)) & 1)) {
12026 PerlMem_free(vmsin);
12027 PerlMem_free(vmsout);
12030 set_vaxc_errno(sts);
12032 case RMS$_FNF: case RMS$_DNF:
12033 set_errno(ENOENT); break;
12035 set_errno(ENOTDIR); break;
12037 set_errno(ENODEV); break;
12039 set_errno(EINVAL); break;
12041 set_errno(EACCES); break;
12043 set_errno(EVMSERR);
12050 fab_out.fab$w_ifi = 0;
12051 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12052 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12053 fab_out.fab$l_fop = FAB$M_SQO;
12054 rms_bind_fab_nam(fab_out, nam_out);
12055 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12056 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12057 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12058 esa_out = PerlMem_malloc(VMS_MAXRSS);
12059 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
12060 rms_set_rsa(nam_out, NULL, 0);
12061 rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
12063 if (preserve_dates == 0) { /* Act like DCL COPY */
12064 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12065 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
12066 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12067 PerlMem_free(vmsin);
12068 PerlMem_free(vmsout);
12071 PerlMem_free(esa_out);
12072 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12073 set_vaxc_errno(sts);
12076 fab_out.fab$l_xab = (void *) &xabdat;
12077 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12078 preserve_dates = 1;
12080 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12081 preserve_dates =0; /* bitmask from this point forward */
12083 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12084 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12085 PerlMem_free(vmsin);
12086 PerlMem_free(vmsout);
12089 PerlMem_free(esa_out);
12090 set_vaxc_errno(sts);
12093 set_errno(ENOENT); break;
12095 set_errno(ENOTDIR); break;
12097 set_errno(ENODEV); break;
12099 set_errno(EINVAL); break;
12101 set_errno(EACCES); break;
12103 set_errno(EVMSERR);
12107 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12108 if (preserve_dates & 2) {
12109 /* sys$close() will process xabrdt, not xabdat */
12110 xabrdt = cc$rms_xabrdt;
12112 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12114 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12115 * is unsigned long[2], while DECC & VAXC use a struct */
12116 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12118 fab_out.fab$l_xab = (void *) &xabrdt;
12121 ubf = PerlMem_malloc(32256);
12122 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12123 rab_in = cc$rms_rab;
12124 rab_in.rab$l_fab = &fab_in;
12125 rab_in.rab$l_rop = RAB$M_BIO;
12126 rab_in.rab$l_ubf = ubf;
12127 rab_in.rab$w_usz = 32256;
12128 if (!((sts = sys$connect(&rab_in)) & 1)) {
12129 sys$close(&fab_in); sys$close(&fab_out);
12130 PerlMem_free(vmsin);
12131 PerlMem_free(vmsout);
12135 PerlMem_free(esa_out);
12136 set_errno(EVMSERR); set_vaxc_errno(sts);
12140 rab_out = cc$rms_rab;
12141 rab_out.rab$l_fab = &fab_out;
12142 rab_out.rab$l_rbf = ubf;
12143 if (!((sts = sys$connect(&rab_out)) & 1)) {
12144 sys$close(&fab_in); sys$close(&fab_out);
12145 PerlMem_free(vmsin);
12146 PerlMem_free(vmsout);
12150 PerlMem_free(esa_out);
12151 set_errno(EVMSERR); set_vaxc_errno(sts);
12155 while ((sts = sys$read(&rab_in))) { /* always true */
12156 if (sts == RMS$_EOF) break;
12157 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12158 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12159 sys$close(&fab_in); sys$close(&fab_out);
12160 PerlMem_free(vmsin);
12161 PerlMem_free(vmsout);
12165 PerlMem_free(esa_out);
12166 set_errno(EVMSERR); set_vaxc_errno(sts);
12172 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12173 sys$close(&fab_in); sys$close(&fab_out);
12174 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12176 PerlMem_free(vmsin);
12177 PerlMem_free(vmsout);
12181 PerlMem_free(esa_out);
12182 set_errno(EVMSERR); set_vaxc_errno(sts);
12186 PerlMem_free(vmsin);
12187 PerlMem_free(vmsout);
12191 PerlMem_free(esa_out);
12194 } /* end of rmscopy() */
12198 /*** The following glue provides 'hooks' to make some of the routines
12199 * from this file available from Perl. These routines are sufficiently
12200 * basic, and are required sufficiently early in the build process,
12201 * that's it's nice to have them available to miniperl as well as the
12202 * full Perl, so they're set up here instead of in an extension. The
12203 * Perl code which handles importation of these names into a given
12204 * package lives in [.VMS]Filespec.pm in @INC.
12208 rmsexpand_fromperl(pTHX_ CV *cv)
12211 char *fspec, *defspec = NULL, *rslt;
12213 int fs_utf8, dfs_utf8;
12217 if (!items || items > 2)
12218 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12219 fspec = SvPV(ST(0),n_a);
12220 fs_utf8 = SvUTF8(ST(0));
12221 if (!fspec || !*fspec) XSRETURN_UNDEF;
12223 defspec = SvPV(ST(1),n_a);
12224 dfs_utf8 = SvUTF8(ST(1));
12226 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12227 ST(0) = sv_newmortal();
12228 if (rslt != NULL) {
12229 sv_usepvn(ST(0),rslt,strlen(rslt));
12238 vmsify_fromperl(pTHX_ CV *cv)
12245 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12246 utf8_fl = SvUTF8(ST(0));
12247 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12248 ST(0) = sv_newmortal();
12249 if (vmsified != NULL) {
12250 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12259 unixify_fromperl(pTHX_ CV *cv)
12266 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12267 utf8_fl = SvUTF8(ST(0));
12268 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12269 ST(0) = sv_newmortal();
12270 if (unixified != NULL) {
12271 sv_usepvn(ST(0),unixified,strlen(unixified));
12280 fileify_fromperl(pTHX_ CV *cv)
12287 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12288 utf8_fl = SvUTF8(ST(0));
12289 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12290 ST(0) = sv_newmortal();
12291 if (fileified != NULL) {
12292 sv_usepvn(ST(0),fileified,strlen(fileified));
12301 pathify_fromperl(pTHX_ CV *cv)
12308 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12309 utf8_fl = SvUTF8(ST(0));
12310 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12311 ST(0) = sv_newmortal();
12312 if (pathified != NULL) {
12313 sv_usepvn(ST(0),pathified,strlen(pathified));
12322 vmspath_fromperl(pTHX_ CV *cv)
12329 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12330 utf8_fl = SvUTF8(ST(0));
12331 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12332 ST(0) = sv_newmortal();
12333 if (vmspath != NULL) {
12334 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12343 unixpath_fromperl(pTHX_ CV *cv)
12350 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12351 utf8_fl = SvUTF8(ST(0));
12352 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12353 ST(0) = sv_newmortal();
12354 if (unixpath != NULL) {
12355 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12364 candelete_fromperl(pTHX_ CV *cv)
12372 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12374 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12375 Newx(fspec, VMS_MAXRSS, char);
12376 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12377 if (SvTYPE(mysv) == SVt_PVGV) {
12378 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12379 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12387 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12388 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12395 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12401 rmscopy_fromperl(pTHX_ CV *cv)
12404 char *inspec, *outspec, *inp, *outp;
12406 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12407 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12408 unsigned long int sts;
12413 if (items < 2 || items > 3)
12414 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12416 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12417 Newx(inspec, VMS_MAXRSS, char);
12418 if (SvTYPE(mysv) == SVt_PVGV) {
12419 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12420 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12428 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12429 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12435 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12436 Newx(outspec, VMS_MAXRSS, char);
12437 if (SvTYPE(mysv) == SVt_PVGV) {
12438 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12439 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12448 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12449 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12456 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12458 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12464 /* The mod2fname is limited to shorter filenames by design, so it should
12465 * not be modified to support longer EFS pathnames
12468 mod2fname(pTHX_ CV *cv)
12471 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12472 workbuff[NAM$C_MAXRSS*1 + 1];
12473 int total_namelen = 3, counter, num_entries;
12474 /* ODS-5 ups this, but we want to be consistent, so... */
12475 int max_name_len = 39;
12476 AV *in_array = (AV *)SvRV(ST(0));
12478 num_entries = av_len(in_array);
12480 /* All the names start with PL_. */
12481 strcpy(ultimate_name, "PL_");
12483 /* Clean up our working buffer */
12484 Zero(work_name, sizeof(work_name), char);
12486 /* Run through the entries and build up a working name */
12487 for(counter = 0; counter <= num_entries; counter++) {
12488 /* If it's not the first name then tack on a __ */
12490 strcat(work_name, "__");
12492 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
12496 /* Check to see if we actually have to bother...*/
12497 if (strlen(work_name) + 3 <= max_name_len) {
12498 strcat(ultimate_name, work_name);
12500 /* It's too darned big, so we need to go strip. We use the same */
12501 /* algorithm as xsubpp does. First, strip out doubled __ */
12502 char *source, *dest, last;
12505 for (source = work_name; *source; source++) {
12506 if (last == *source && last == '_') {
12512 /* Go put it back */
12513 strcpy(work_name, workbuff);
12514 /* Is it still too big? */
12515 if (strlen(work_name) + 3 > max_name_len) {
12516 /* Strip duplicate letters */
12519 for (source = work_name; *source; source++) {
12520 if (last == toupper(*source)) {
12524 last = toupper(*source);
12526 strcpy(work_name, workbuff);
12529 /* Is it *still* too big? */
12530 if (strlen(work_name) + 3 > max_name_len) {
12531 /* Too bad, we truncate */
12532 work_name[max_name_len - 2] = 0;
12534 strcat(ultimate_name, work_name);
12537 /* Okay, return it */
12538 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12543 hushexit_fromperl(pTHX_ CV *cv)
12548 VMSISH_HUSHED = SvTRUE(ST(0));
12550 ST(0) = boolSV(VMSISH_HUSHED);
12556 Perl_vms_start_glob
12557 (pTHX_ SV *tmpglob,
12561 struct vs_str_st *rslt;
12565 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12568 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12569 struct dsc$descriptor_vs rsdsc;
12570 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12571 unsigned long hasver = 0, isunix = 0;
12572 unsigned long int lff_flags = 0;
12575 #ifdef VMS_LONGNAME_SUPPORT
12576 lff_flags = LIB$M_FIL_LONG_NAMES;
12578 /* The Newx macro will not allow me to assign a smaller array
12579 * to the rslt pointer, so we will assign it to the begin char pointer
12580 * and then copy the value into the rslt pointer.
12582 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12583 rslt = (struct vs_str_st *)begin;
12585 rstr = &rslt->str[0];
12586 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12587 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12588 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12589 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12591 Newx(vmsspec, VMS_MAXRSS, char);
12593 /* We could find out if there's an explicit dev/dir or version
12594 by peeking into lib$find_file's internal context at
12595 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12596 but that's unsupported, so I don't want to do it now and
12597 have it bite someone in the future. */
12598 /* Fix-me: vms_split_path() is the only way to do this, the
12599 existing method will fail with many legal EFS or UNIX specifications
12602 cp = SvPV(tmpglob,i);
12605 if (cp[i] == ';') hasver = 1;
12606 if (cp[i] == '.') {
12607 if (sts) hasver = 1;
12610 if (cp[i] == '/') {
12611 hasdir = isunix = 1;
12614 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12619 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12623 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12624 if (!stat_sts && S_ISDIR(st.st_mode)) {
12625 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12626 ok = (wilddsc.dsc$a_pointer != NULL);
12627 /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12631 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12632 ok = (wilddsc.dsc$a_pointer != NULL);
12635 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12637 /* If not extended character set, replace ? with % */
12638 /* With extended character set, ? is a wildcard single character */
12639 if (!decc_efs_case_preserve) {
12640 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12641 if (*cp == '?') *cp = '%';
12644 while (ok && $VMS_STATUS_SUCCESS(sts)) {
12645 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12646 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12648 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12649 &dfltdsc,NULL,&rms_sts,&lff_flags);
12650 if (!$VMS_STATUS_SUCCESS(sts))
12655 /* with varying string, 1st word of buffer contains result length */
12656 rstr[rslt->length] = '\0';
12658 /* Find where all the components are */
12659 v_sts = vms_split_path
12674 /* If no version on input, truncate the version on output */
12675 if (!hasver && (vs_len > 0)) {
12679 /* No version & a null extension on UNIX handling */
12680 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12686 if (!decc_efs_case_preserve) {
12687 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12691 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12695 /* Start with the name */
12698 strcat(begin,"\n");
12699 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12701 if (cxt) (void)lib$find_file_end(&cxt);
12704 /* Be POSIXish: return the input pattern when no matches */
12705 begin = SvPVX(tmpglob);
12706 strcat(begin,"\n");
12707 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12710 if (ok && sts != RMS$_NMF &&
12711 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12714 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12716 PerlIO_close(tmpfp);
12720 PerlIO_rewind(tmpfp);
12721 IoTYPE(io) = IoTYPE_RDONLY;
12722 IoIFP(io) = fp = tmpfp;
12723 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
12734 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12735 const int *utf8_fl);
12738 vms_realpath_fromperl(pTHX_ CV *cv)
12741 char *fspec, *rslt_spec, *rslt;
12744 if (!items || items != 1)
12745 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12747 fspec = SvPV(ST(0),n_a);
12748 if (!fspec || !*fspec) XSRETURN_UNDEF;
12750 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12751 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12752 ST(0) = sv_newmortal();
12754 sv_usepvn(ST(0),rslt,strlen(rslt));
12756 Safefree(rslt_spec);
12761 * A thin wrapper around decc$symlink to make sure we follow the
12762 * standard and do not create a symlink with a zero-length name.
12764 /*{{{ int my_symlink(const char *path1, const char *path2)*/
12765 int my_symlink(const char *path1, const char *path2) {
12766 if (!path2 || !*path2) {
12767 SETERRNO(ENOENT, SS$_NOSUCHFILE);
12770 return symlink(path1, path2);
12774 #endif /* HAS_SYMLINK */
12776 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12777 int do_vms_case_tolerant(void);
12780 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12783 ST(0) = boolSV(do_vms_case_tolerant());
12789 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12790 struct interp_intern *dst)
12792 memcpy(dst,src,sizeof(struct interp_intern));
12796 Perl_sys_intern_clear(pTHX)
12801 Perl_sys_intern_init(pTHX)
12803 unsigned int ix = RAND_MAX;
12808 /* fix me later to track running under GNV */
12809 /* this allows some limited testing */
12810 MY_POSIX_EXIT = decc_filename_unix_report;
12813 MY_INV_RAND_MAX = 1./x;
12817 init_os_extras(void)
12820 char* file = __FILE__;
12821 if (decc_disable_to_vms_logname_translation) {
12822 no_translate_barewords = TRUE;
12824 no_translate_barewords = FALSE;
12827 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12828 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12829 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12830 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12831 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12832 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12833 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12834 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12835 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12836 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12837 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12839 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12841 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12842 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12845 store_pipelocs(aTHX); /* will redo any earlier attempts */
12852 #if __CRTL_VER == 80200000
12853 /* This missed getting in to the DECC SDK for 8.2 */
12854 char *realpath(const char *file_name, char * resolved_name, ...);
12857 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12858 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12859 * The perl fallback routine to provide realpath() is not as efficient
12863 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
12864 const int *utf8_fl)
12866 return realpath(filespec, outbuf);
12870 /* External entry points */
12871 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12872 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12874 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12879 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12880 /* case_tolerant */
12882 /*{{{int do_vms_case_tolerant(void)*/
12883 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12884 * controlled by a process setting.
12886 int do_vms_case_tolerant(void)
12888 return vms_process_case_tolerant;
12891 /* External entry points */
12892 int Perl_vms_case_tolerant(void)
12893 { return do_vms_case_tolerant(); }
12895 int Perl_vms_case_tolerant(void)
12896 { return vms_process_case_tolerant; }
12900 /* Start of DECC RTL Feature handling */
12902 static int sys_trnlnm
12903 (const char * logname,
12907 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12908 const unsigned long attr = LNM$M_CASE_BLIND;
12909 struct dsc$descriptor_s name_dsc;
12911 unsigned short result;
12912 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12915 name_dsc.dsc$w_length = strlen(logname);
12916 name_dsc.dsc$a_pointer = (char *)logname;
12917 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12918 name_dsc.dsc$b_class = DSC$K_CLASS_S;
12920 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12922 if ($VMS_STATUS_SUCCESS(status)) {
12924 /* Null terminate and return the string */
12925 /*--------------------------------------*/
12932 static int sys_crelnm
12933 (const char * logname,
12934 const char * value)
12937 const char * proc_table = "LNM$PROCESS_TABLE";
12938 struct dsc$descriptor_s proc_table_dsc;
12939 struct dsc$descriptor_s logname_dsc;
12940 struct itmlst_3 item_list[2];
12942 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12943 proc_table_dsc.dsc$w_length = strlen(proc_table);
12944 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12945 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12947 logname_dsc.dsc$a_pointer = (char *) logname;
12948 logname_dsc.dsc$w_length = strlen(logname);
12949 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12950 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12952 item_list[0].buflen = strlen(value);
12953 item_list[0].itmcode = LNM$_STRING;
12954 item_list[0].bufadr = (char *)value;
12955 item_list[0].retlen = NULL;
12957 item_list[1].buflen = 0;
12958 item_list[1].itmcode = 0;
12960 ret_val = sys$crelnm
12962 (const struct dsc$descriptor_s *)&proc_table_dsc,
12963 (const struct dsc$descriptor_s *)&logname_dsc,
12965 (const struct item_list_3 *) item_list);
12970 /* C RTL Feature settings */
12972 static int set_features
12973 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
12974 int (* cli_routine)(void), /* Not documented */
12975 void *image_info) /* Not documented */
12982 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12983 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12984 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12985 unsigned long case_perm;
12986 unsigned long case_image;
12989 /* Allow an exception to bring Perl into the VMS debugger */
12990 vms_debug_on_exception = 0;
12991 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12992 if ($VMS_STATUS_SUCCESS(status)) {
12993 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12994 vms_debug_on_exception = 1;
12996 vms_debug_on_exception = 0;
12999 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13000 vms_vtf7_filenames = 0;
13001 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13002 if ($VMS_STATUS_SUCCESS(status)) {
13003 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13004 vms_vtf7_filenames = 1;
13006 vms_vtf7_filenames = 0;
13010 /* unlink all versions on unlink() or rename() */
13011 vms_vtf7_filenames = 0;
13012 status = sys_trnlnm
13013 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13014 if ($VMS_STATUS_SUCCESS(status)) {
13015 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13016 vms_unlink_all_versions = 1;
13018 vms_unlink_all_versions = 0;
13021 /* Dectect running under GNV Bash or other UNIX like shell */
13022 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13023 gnv_unix_shell = 0;
13024 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13025 if ($VMS_STATUS_SUCCESS(status)) {
13026 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13027 gnv_unix_shell = 1;
13028 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13029 set_feature_default("DECC$EFS_CHARSET", 1);
13030 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13031 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13032 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13033 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13034 vms_unlink_all_versions = 1;
13037 gnv_unix_shell = 0;
13041 /* hacks to see if known bugs are still present for testing */
13043 /* Readdir is returning filenames in VMS syntax always */
13044 decc_bug_readdir_efs1 = 1;
13045 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13046 if ($VMS_STATUS_SUCCESS(status)) {
13047 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13048 decc_bug_readdir_efs1 = 1;
13050 decc_bug_readdir_efs1 = 0;
13053 /* PCP mode requires creating /dev/null special device file */
13054 decc_bug_devnull = 0;
13055 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13056 if ($VMS_STATUS_SUCCESS(status)) {
13057 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13058 decc_bug_devnull = 1;
13060 decc_bug_devnull = 0;
13063 /* fgetname returning a VMS name in UNIX mode */
13064 decc_bug_fgetname = 1;
13065 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13066 if ($VMS_STATUS_SUCCESS(status)) {
13067 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13068 decc_bug_fgetname = 1;
13070 decc_bug_fgetname = 0;
13073 /* UNIX directory names with no paths are broken in a lot of places */
13074 decc_dir_barename = 1;
13075 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13076 if ($VMS_STATUS_SUCCESS(status)) {
13077 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13078 decc_dir_barename = 1;
13080 decc_dir_barename = 0;
13083 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13084 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13086 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13087 if (decc_disable_to_vms_logname_translation < 0)
13088 decc_disable_to_vms_logname_translation = 0;
13091 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13093 decc_efs_case_preserve = decc$feature_get_value(s, 1);
13094 if (decc_efs_case_preserve < 0)
13095 decc_efs_case_preserve = 0;
13098 s = decc$feature_get_index("DECC$EFS_CHARSET");
13100 decc_efs_charset = decc$feature_get_value(s, 1);
13101 if (decc_efs_charset < 0)
13102 decc_efs_charset = 0;
13105 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13107 decc_filename_unix_report = decc$feature_get_value(s, 1);
13108 if (decc_filename_unix_report > 0)
13109 decc_filename_unix_report = 1;
13111 decc_filename_unix_report = 0;
13114 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13116 decc_filename_unix_only = decc$feature_get_value(s, 1);
13117 if (decc_filename_unix_only > 0) {
13118 decc_filename_unix_only = 1;
13121 decc_filename_unix_only = 0;
13125 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13127 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13128 if (decc_filename_unix_no_version < 0)
13129 decc_filename_unix_no_version = 0;
13132 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13134 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13135 if (decc_readdir_dropdotnotype < 0)
13136 decc_readdir_dropdotnotype = 0;
13139 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13140 if ($VMS_STATUS_SUCCESS(status)) {
13141 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13143 dflt = decc$feature_get_value(s, 4);
13145 decc_disable_posix_root = decc$feature_get_value(s, 1);
13146 if (decc_disable_posix_root <= 0) {
13147 decc$feature_set_value(s, 1, 1);
13148 decc_disable_posix_root = 1;
13152 /* Traditionally Perl assumes this is off */
13153 decc_disable_posix_root = 1;
13154 decc$feature_set_value(s, 1, 1);
13159 #if __CRTL_VER >= 80200000
13160 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13162 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13163 if (decc_posix_compliant_pathnames < 0)
13164 decc_posix_compliant_pathnames = 0;
13165 if (decc_posix_compliant_pathnames > 4)
13166 decc_posix_compliant_pathnames = 0;
13171 status = sys_trnlnm
13172 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13173 if ($VMS_STATUS_SUCCESS(status)) {
13174 val_str[0] = _toupper(val_str[0]);
13175 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13176 decc_disable_to_vms_logname_translation = 1;
13181 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13182 if ($VMS_STATUS_SUCCESS(status)) {
13183 val_str[0] = _toupper(val_str[0]);
13184 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13185 decc_efs_case_preserve = 1;
13190 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13191 if ($VMS_STATUS_SUCCESS(status)) {
13192 val_str[0] = _toupper(val_str[0]);
13193 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13194 decc_filename_unix_report = 1;
13197 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13198 if ($VMS_STATUS_SUCCESS(status)) {
13199 val_str[0] = _toupper(val_str[0]);
13200 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13201 decc_filename_unix_only = 1;
13202 decc_filename_unix_report = 1;
13205 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13206 if ($VMS_STATUS_SUCCESS(status)) {
13207 val_str[0] = _toupper(val_str[0]);
13208 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13209 decc_filename_unix_no_version = 1;
13212 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13213 if ($VMS_STATUS_SUCCESS(status)) {
13214 val_str[0] = _toupper(val_str[0]);
13215 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13216 decc_readdir_dropdotnotype = 1;
13221 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13223 /* Report true case tolerance */
13224 /*----------------------------*/
13225 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13226 if (!$VMS_STATUS_SUCCESS(status))
13227 case_perm = PPROP$K_CASE_BLIND;
13228 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13229 if (!$VMS_STATUS_SUCCESS(status))
13230 case_image = PPROP$K_CASE_BLIND;
13231 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13232 (case_image == PPROP$K_CASE_SENSITIVE))
13233 vms_process_case_tolerant = 0;
13238 /* CRTL can be initialized past this point, but not before. */
13239 /* DECC$CRTL_INIT(); */
13246 #pragma extern_model save
13247 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13248 const __align (LONGWORD) int spare[8] = {0};
13250 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13251 #if __DECC_VER >= 60560002
13252 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13254 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13256 #endif /* __DECC */
13258 const long vms_cc_features = (const long)set_features;
13261 ** Force a reference to LIB$INITIALIZE to ensure it
13262 ** exists in the image.
13264 int lib$initialize(void);
13266 #pragma extern_model strict_refdef
13268 int lib_init_ref = (int) lib$initialize;
13271 #pragma extern_model restore