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(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(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 a NAML block is used RMS always writes to the long and short
5385 * addresses unless you suppress the short name.
5387 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5388 outbufl = PerlMem_malloc(VMS_MAXRSS);
5389 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
5391 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5393 #ifdef NAM$M_NO_SHORT_UPCASE
5394 if (decc_efs_case_preserve)
5395 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5398 /* We may not want to follow symbolic links */
5399 #ifdef NAML$M_OPEN_SPECIAL
5400 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5401 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5404 /* First attempt to parse as an existing file */
5405 retsts = sys$parse(&myfab,0,0);
5406 if (!(retsts & STS$K_SUCCESS)) {
5408 /* Could not find the file, try as syntax only if error is not fatal */
5409 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5410 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5411 retsts = sys$parse(&myfab,0,0);
5412 if (retsts & STS$K_SUCCESS) goto expanded;
5415 /* Still could not parse the file specification */
5416 /*----------------------------------------------*/
5417 sts = rms_free_search_context(&myfab); /* Free search context */
5418 if (out) Safefree(out);
5419 if (tmpfspec != NULL)
5420 PerlMem_free(tmpfspec);
5421 if (vmsfspec != NULL)
5422 PerlMem_free(vmsfspec);
5423 if (outbufl != NULL)
5424 PerlMem_free(outbufl);
5428 set_vaxc_errno(retsts);
5429 if (retsts == RMS$_PRV) set_errno(EACCES);
5430 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5431 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5432 else set_errno(EVMSERR);
5435 retsts = sys$search(&myfab,0,0);
5436 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5437 sts = rms_free_search_context(&myfab); /* Free search context */
5438 if (out) Safefree(out);
5439 if (tmpfspec != NULL)
5440 PerlMem_free(tmpfspec);
5441 if (vmsfspec != NULL)
5442 PerlMem_free(vmsfspec);
5443 if (outbufl != NULL)
5444 PerlMem_free(outbufl);
5448 set_vaxc_errno(retsts);
5449 if (retsts == RMS$_PRV) set_errno(EACCES);
5450 else set_errno(EVMSERR);
5454 /* If the input filespec contained any lowercase characters,
5455 * downcase the result for compatibility with Unix-minded code. */
5457 if (!decc_efs_case_preserve) {
5458 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5459 if (islower(*tbuf)) { haslower = 1; break; }
5462 /* Is a long or a short name expected */
5463 /*------------------------------------*/
5464 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5465 if (rms_nam_rsll(mynam)) {
5467 speclen = rms_nam_rsll(mynam);
5470 tbuf = esal; /* Not esa */
5471 speclen = rms_nam_esll(mynam);
5475 if (rms_nam_rsl(mynam)) {
5477 speclen = rms_nam_rsl(mynam);
5480 tbuf = esa; /* Not esal */
5481 speclen = rms_nam_esl(mynam);
5484 tbuf[speclen] = '\0';
5486 /* Trim off null fields added by $PARSE
5487 * If type > 1 char, must have been specified in original or default spec
5488 * (not true for version; $SEARCH may have added version of existing file).
5490 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5491 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5492 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5493 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5496 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5497 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5499 if (trimver || trimtype) {
5500 if (defspec && *defspec) {
5501 char *defesal = NULL;
5502 char *defesa = NULL;
5503 defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5504 if (defesa != NULL) {
5505 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5506 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5507 if (defesal == NULL) _ckvmssts(SS$_INSFMEM);
5509 struct FAB deffab = cc$rms_fab;
5510 rms_setup_nam(defnam);
5512 rms_bind_fab_nam(deffab, defnam);
5516 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5518 /* RMS needs the esa/esal as a work area if wildcards are involved */
5519 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5521 rms_clear_nam_nop(defnam);
5522 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5523 #ifdef NAM$M_NO_SHORT_UPCASE
5524 if (decc_efs_case_preserve)
5525 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5527 #ifdef NAML$M_OPEN_SPECIAL
5528 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5529 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5531 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5533 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5536 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5539 if (defesal != NULL)
5540 PerlMem_free(defesal);
5541 PerlMem_free(defesa);
5545 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5546 if (*(rms_nam_verl(mynam)) != '\"')
5547 speclen = rms_nam_verl(mynam) - tbuf;
5550 if (*(rms_nam_ver(mynam)) != '\"')
5551 speclen = rms_nam_ver(mynam) - tbuf;
5555 /* If we didn't already trim version, copy down */
5556 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5557 if (speclen > rms_nam_verl(mynam) - tbuf)
5559 (rms_nam_typel(mynam),
5560 rms_nam_verl(mynam),
5561 speclen - (rms_nam_verl(mynam) - tbuf));
5562 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5565 if (speclen > rms_nam_ver(mynam) - tbuf)
5567 (rms_nam_type(mynam),
5569 speclen - (rms_nam_ver(mynam) - tbuf));
5570 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5575 /* Done with these copies of the input files */
5576 /*-------------------------------------------*/
5577 if (vmsfspec != NULL)
5578 PerlMem_free(vmsfspec);
5579 if (tmpfspec != NULL)
5580 PerlMem_free(tmpfspec);
5582 /* If we just had a directory spec on input, $PARSE "helpfully"
5583 * adds an empty name and type for us */
5584 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5585 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5586 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5587 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5588 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5589 speclen = rms_nam_namel(mynam) - tbuf;
5594 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5595 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5596 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5597 speclen = rms_nam_name(mynam) - tbuf;
5600 /* Posix format specifications must have matching quotes */
5601 if (speclen < (VMS_MAXRSS - 1)) {
5602 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5603 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5604 tbuf[speclen] = '\"';
5609 tbuf[speclen] = '\0';
5610 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5612 /* Have we been working with an expanded, but not resultant, spec? */
5613 /* Also, convert back to Unix syntax if necessary. */
5617 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5618 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5619 rsl = rms_nam_rsll(mynam);
5623 rsl = rms_nam_rsl(mynam);
5627 if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5628 if (out) Safefree(out);
5632 if (outbufl != NULL)
5633 PerlMem_free(outbufl);
5637 else strcpy(outbuf, tbuf);
5640 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5641 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5642 if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
5643 if (out) Safefree(out);
5647 PerlMem_free(tmpfspec);
5648 if (outbufl != NULL)
5649 PerlMem_free(outbufl);
5652 strcpy(outbuf,tmpfspec);
5653 PerlMem_free(tmpfspec);
5656 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5657 sts = rms_free_search_context(&myfab); /* Free search context */
5661 if (outbufl != NULL)
5662 PerlMem_free(outbufl);
5666 /* External entry points */
5667 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5668 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5669 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5670 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5671 char *Perl_rmsexpand_utf8
5672 (pTHX_ const char *spec, char *buf, const char *def,
5673 unsigned opt, int * fs_utf8, int * dfs_utf8)
5674 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5675 char *Perl_rmsexpand_utf8_ts
5676 (pTHX_ const char *spec, char *buf, const char *def,
5677 unsigned opt, int * fs_utf8, int * dfs_utf8)
5678 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5682 ** The following routines are provided to make life easier when
5683 ** converting among VMS-style and Unix-style directory specifications.
5684 ** All will take input specifications in either VMS or Unix syntax. On
5685 ** failure, all return NULL. If successful, the routines listed below
5686 ** return a pointer to a buffer containing the appropriately
5687 ** reformatted spec (and, therefore, subsequent calls to that routine
5688 ** will clobber the result), while the routines of the same names with
5689 ** a _ts suffix appended will return a pointer to a mallocd string
5690 ** containing the appropriately reformatted spec.
5691 ** In all cases, only explicit syntax is altered; no check is made that
5692 ** the resulting string is valid or that the directory in question
5695 ** fileify_dirspec() - convert a directory spec into the name of the
5696 ** directory file (i.e. what you can stat() to see if it's a dir).
5697 ** The style (VMS or Unix) of the result is the same as the style
5698 ** of the parameter passed in.
5699 ** pathify_dirspec() - convert a directory spec into a path (i.e.
5700 ** what you prepend to a filename to indicate what directory it's in).
5701 ** The style (VMS or Unix) of the result is the same as the style
5702 ** of the parameter passed in.
5703 ** tounixpath() - convert a directory spec into a Unix-style path.
5704 ** tovmspath() - convert a directory spec into a VMS-style path.
5705 ** tounixspec() - convert any file spec into a Unix-style file spec.
5706 ** tovmsspec() - convert any file spec into a VMS-style spec.
5707 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5709 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
5710 ** Permission is given to distribute this code as part of the Perl
5711 ** standard distribution under the terms of the GNU General Public
5712 ** License or the Perl Artistic License. Copies of each may be
5713 ** found in the Perl standard distribution.
5716 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5717 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5719 static char __fileify_retbuf[VMS_MAXRSS];
5720 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5721 char *retspec, *cp1, *cp2, *lastdir;
5722 char *trndir, *vmsdir;
5723 unsigned short int trnlnm_iter_count;
5725 if (utf8_fl != NULL)
5728 if (!dir || !*dir) {
5729 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5731 dirlen = strlen(dir);
5732 while (dirlen && dir[dirlen-1] == '/') --dirlen;
5733 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5734 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5741 if (dirlen > (VMS_MAXRSS - 1)) {
5742 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5745 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5746 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5747 if (!strpbrk(dir+1,"/]>:") &&
5748 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5749 strcpy(trndir,*dir == '/' ? dir + 1: dir);
5750 trnlnm_iter_count = 0;
5751 while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5752 trnlnm_iter_count++;
5753 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5755 dirlen = strlen(trndir);
5758 strncpy(trndir,dir,dirlen);
5759 trndir[dirlen] = '\0';
5762 /* At this point we are done with *dir and use *trndir which is a
5763 * copy that can be modified. *dir must not be modified.
5766 /* If we were handed a rooted logical name or spec, treat it like a
5767 * simple directory, so that
5768 * $ Define myroot dev:[dir.]
5769 * ... do_fileify_dirspec("myroot",buf,1) ...
5770 * does something useful.
5772 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5773 trndir[--dirlen] = '\0';
5774 trndir[dirlen-1] = ']';
5776 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5777 trndir[--dirlen] = '\0';
5778 trndir[dirlen-1] = '>';
5781 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5782 /* If we've got an explicit filename, we can just shuffle the string. */
5783 if (*(cp1+1)) hasfilename = 1;
5784 /* Similarly, we can just back up a level if we've got multiple levels
5785 of explicit directories in a VMS spec which ends with directories. */
5787 for (cp2 = cp1; cp2 > trndir; cp2--) {
5789 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5790 /* fix-me, can not scan EFS file specs backward like this */
5791 *cp2 = *cp1; *cp1 = '\0';
5796 if (*cp2 == '[' || *cp2 == '<') break;
5801 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5802 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5803 cp1 = strpbrk(trndir,"]:>");
5804 if (hasfilename || !cp1) { /* Unix-style path or filename */
5805 if (trndir[0] == '.') {
5806 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5807 PerlMem_free(trndir);
5808 PerlMem_free(vmsdir);
5809 return do_fileify_dirspec("[]",buf,ts,NULL);
5811 else if (trndir[1] == '.' &&
5812 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5813 PerlMem_free(trndir);
5814 PerlMem_free(vmsdir);
5815 return do_fileify_dirspec("[-]",buf,ts,NULL);
5818 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
5819 dirlen -= 1; /* to last element */
5820 lastdir = strrchr(trndir,'/');
5822 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5823 /* If we have "/." or "/..", VMSify it and let the VMS code
5824 * below expand it, rather than repeating the code to handle
5825 * relative components of a filespec here */
5827 if (*(cp1+2) == '.') cp1++;
5828 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5830 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5831 PerlMem_free(trndir);
5832 PerlMem_free(vmsdir);
5835 if (strchr(vmsdir,'/') != NULL) {
5836 /* If do_tovmsspec() returned it, it must have VMS syntax
5837 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5838 * the time to check this here only so we avoid a recursion
5839 * loop; otherwise, gigo.
5841 PerlMem_free(trndir);
5842 PerlMem_free(vmsdir);
5843 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5846 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5847 PerlMem_free(trndir);
5848 PerlMem_free(vmsdir);
5851 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5852 PerlMem_free(trndir);
5853 PerlMem_free(vmsdir);
5857 } while ((cp1 = strstr(cp1,"/.")) != NULL);
5858 lastdir = strrchr(trndir,'/');
5860 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5862 /* Ditto for specs that end in an MFD -- let the VMS code
5863 * figure out whether it's a real device or a rooted logical. */
5865 /* This should not happen any more. Allowing the fake /000000
5866 * in a UNIX pathname causes all sorts of problems when trying
5867 * to run in UNIX emulation. So the VMS to UNIX conversions
5868 * now remove the fake /000000 directories.
5871 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5872 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5873 PerlMem_free(trndir);
5874 PerlMem_free(vmsdir);
5877 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5878 PerlMem_free(trndir);
5879 PerlMem_free(vmsdir);
5882 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5883 PerlMem_free(trndir);
5884 PerlMem_free(vmsdir);
5889 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5890 !(lastdir = cp1 = strrchr(trndir,']')) &&
5891 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5892 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
5895 /* For EFS or ODS-5 look for the last dot */
5896 if (decc_efs_charset) {
5897 cp2 = strrchr(cp1,'.');
5899 if (vms_process_case_tolerant) {
5900 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5901 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5902 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5903 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5904 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5905 (ver || *cp3)))))) {
5906 PerlMem_free(trndir);
5907 PerlMem_free(vmsdir);
5909 set_vaxc_errno(RMS$_DIR);
5914 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5915 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5916 !*(cp2+3) || *(cp2+3) != 'R' ||
5917 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5918 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5919 (ver || *cp3)))))) {
5920 PerlMem_free(trndir);
5921 PerlMem_free(vmsdir);
5923 set_vaxc_errno(RMS$_DIR);
5927 dirlen = cp2 - trndir;
5931 retlen = dirlen + 6;
5932 if (buf) retspec = buf;
5933 else if (ts) Newx(retspec,retlen+1,char);
5934 else retspec = __fileify_retbuf;
5935 memcpy(retspec,trndir,dirlen);
5936 retspec[dirlen] = '\0';
5938 /* We've picked up everything up to the directory file name.
5939 Now just add the type and version, and we're set. */
5940 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5941 strcat(retspec,".dir;1");
5943 strcat(retspec,".DIR;1");
5944 PerlMem_free(trndir);
5945 PerlMem_free(vmsdir);
5948 else { /* VMS-style directory spec */
5950 char *esa, *esal, term, *cp;
5953 unsigned long int sts, cmplen, haslower = 0;
5954 unsigned int nam_fnb;
5956 struct FAB dirfab = cc$rms_fab;
5957 rms_setup_nam(savnam);
5958 rms_setup_nam(dirnam);
5960 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5961 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5963 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5964 esal = PerlMem_malloc(VMS_MAXRSS);
5965 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5967 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5968 rms_bind_fab_nam(dirfab, dirnam);
5969 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5970 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
5971 #ifdef NAM$M_NO_SHORT_UPCASE
5972 if (decc_efs_case_preserve)
5973 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5976 for (cp = trndir; *cp; cp++)
5977 if (islower(*cp)) { haslower = 1; break; }
5978 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5979 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5980 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5981 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5987 PerlMem_free(trndir);
5988 PerlMem_free(vmsdir);
5990 set_vaxc_errno(dirfab.fab$l_sts);
5996 /* Does the file really exist? */
5997 if (sys$search(&dirfab)& STS$K_SUCCESS) {
5998 /* Yes; fake the fnb bits so we'll check type below */
5999 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6001 else { /* No; just work with potential name */
6002 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6005 fab_sts = dirfab.fab$l_sts;
6006 sts = rms_free_search_context(&dirfab);
6010 PerlMem_free(trndir);
6011 PerlMem_free(vmsdir);
6012 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
6018 /* Make sure we are using the right buffer */
6021 my_esa_len = rms_nam_esll(dirnam);
6024 my_esa_len = rms_nam_esl(dirnam);
6026 my_esa[my_esa_len] = '\0';
6027 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6028 cp1 = strchr(my_esa,']');
6029 if (!cp1) cp1 = strchr(my_esa,'>');
6030 if (cp1) { /* Should always be true */
6031 my_esa_len -= cp1 - my_esa - 1;
6032 memmove(my_esa, cp1 + 1, my_esa_len);
6035 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6036 /* Yep; check version while we're at it, if it's there. */
6037 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6038 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6039 /* Something other than .DIR[;1]. Bzzt. */
6040 sts = rms_free_search_context(&dirfab);
6044 PerlMem_free(trndir);
6045 PerlMem_free(vmsdir);
6047 set_vaxc_errno(RMS$_DIR);
6052 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6053 /* They provided at least the name; we added the type, if necessary, */
6054 if (buf) retspec = buf; /* in sys$parse() */
6055 else if (ts) Newx(retspec, my_esa_len + 1, char);
6056 else retspec = __fileify_retbuf;
6057 strcpy(retspec,my_esa);
6058 sts = rms_free_search_context(&dirfab);
6059 PerlMem_free(trndir);
6063 PerlMem_free(vmsdir);
6066 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6067 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6071 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6072 if (cp1 == NULL) { /* should never happen */
6073 sts = rms_free_search_context(&dirfab);
6074 PerlMem_free(trndir);
6078 PerlMem_free(vmsdir);
6083 retlen = strlen(my_esa);
6084 cp1 = strrchr(my_esa,'.');
6085 /* ODS-5 directory specifications can have extra "." in them. */
6086 /* Fix-me, can not scan EFS file specifications backwards */
6087 while (cp1 != NULL) {
6088 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6092 while ((cp1 > my_esa) && (*cp1 != '.'))
6099 if ((cp1) != NULL) {
6100 /* There's more than one directory in the path. Just roll back. */
6102 if (buf) retspec = buf;
6103 else if (ts) Newx(retspec,retlen+7,char);
6104 else retspec = __fileify_retbuf;
6105 strcpy(retspec,my_esa);
6108 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6109 /* Go back and expand rooted logical name */
6110 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6111 #ifdef NAM$M_NO_SHORT_UPCASE
6112 if (decc_efs_case_preserve)
6113 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6115 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6116 sts = rms_free_search_context(&dirfab);
6120 PerlMem_free(trndir);
6121 PerlMem_free(vmsdir);
6123 set_vaxc_errno(dirfab.fab$l_sts);
6127 /* This changes the length of the string of course */
6129 my_esa_len = rms_nam_esll(dirnam);
6131 my_esa_len = rms_nam_esl(dirnam);
6134 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6135 if (buf) retspec = buf;
6136 else if (ts) Newx(retspec,retlen+16,char);
6137 else retspec = __fileify_retbuf;
6138 cp1 = strstr(my_esa,"][");
6139 if (!cp1) cp1 = strstr(my_esa,"]<");
6140 dirlen = cp1 - my_esa;
6141 memcpy(retspec,my_esa,dirlen);
6142 if (!strncmp(cp1+2,"000000]",7)) {
6143 retspec[dirlen-1] = '\0';
6144 /* fix-me Not full ODS-5, just extra dots in directories for now */
6145 cp1 = retspec + dirlen - 1;
6146 while (cp1 > retspec)
6151 if (*(cp1-1) != '^')
6156 if (*cp1 == '.') *cp1 = ']';
6158 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6159 memmove(cp1+1,"000000]",7);
6163 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6164 retspec[retlen] = '\0';
6165 /* Convert last '.' to ']' */
6166 cp1 = retspec+retlen-1;
6167 while (*cp != '[') {
6170 /* Do not trip on extra dots in ODS-5 directories */
6171 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6175 if (*cp1 == '.') *cp1 = ']';
6177 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6178 memmove(cp1+1,"000000]",7);
6182 else { /* This is a top-level dir. Add the MFD to the path. */
6183 if (buf) retspec = buf;
6184 else if (ts) Newx(retspec,retlen+16,char);
6185 else retspec = __fileify_retbuf;
6188 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6189 strcpy(cp2,":[000000]");
6194 sts = rms_free_search_context(&dirfab);
6195 /* We've set up the string up through the filename. Add the
6196 type and version, and we're done. */
6197 strcat(retspec,".DIR;1");
6199 /* $PARSE may have upcased filespec, so convert output to lower
6200 * case if input contained any lowercase characters. */
6201 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6202 PerlMem_free(trndir);
6206 PerlMem_free(vmsdir);
6209 } /* end of do_fileify_dirspec() */
6211 /* External entry points */
6212 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6213 { return do_fileify_dirspec(dir,buf,0,NULL); }
6214 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6215 { return do_fileify_dirspec(dir,buf,1,NULL); }
6216 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6217 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6218 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6219 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6221 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6222 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6224 static char __pathify_retbuf[VMS_MAXRSS];
6225 unsigned long int retlen;
6226 char *retpath, *cp1, *cp2, *trndir;
6227 unsigned short int trnlnm_iter_count;
6230 if (utf8_fl != NULL)
6233 if (!dir || !*dir) {
6234 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6237 trndir = PerlMem_malloc(VMS_MAXRSS);
6238 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
6239 if (*dir) strcpy(trndir,dir);
6240 else getcwd(trndir,VMS_MAXRSS - 1);
6242 trnlnm_iter_count = 0;
6243 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6244 && my_trnlnm(trndir,trndir,0)) {
6245 trnlnm_iter_count++;
6246 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6247 trnlen = strlen(trndir);
6249 /* Trap simple rooted lnms, and return lnm:[000000] */
6250 if (!strcmp(trndir+trnlen-2,".]")) {
6251 if (buf) retpath = buf;
6252 else if (ts) Newx(retpath,strlen(dir)+10,char);
6253 else retpath = __pathify_retbuf;
6254 strcpy(retpath,dir);
6255 strcat(retpath,":[000000]");
6256 PerlMem_free(trndir);
6261 /* At this point we do not work with *dir, but the copy in
6262 * *trndir that is modifiable.
6265 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6266 if (*trndir == '.' && (*(trndir+1) == '\0' ||
6267 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6268 retlen = 2 + (*(trndir+1) != '\0');
6270 if ( !(cp1 = strrchr(trndir,'/')) &&
6271 !(cp1 = strrchr(trndir,']')) &&
6272 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6273 if ((cp2 = strchr(cp1,'.')) != NULL &&
6274 (*(cp2-1) != '/' || /* Trailing '.', '..', */
6275 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
6276 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6277 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6280 /* For EFS or ODS-5 look for the last dot */
6281 if (decc_efs_charset) {
6282 cp2 = strrchr(cp1,'.');
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);
6310 retlen = cp2 - trndir + 1;
6312 else { /* No file type present. Treat the filename as a directory. */
6313 retlen = strlen(trndir) + 1;
6316 if (buf) retpath = buf;
6317 else if (ts) Newx(retpath,retlen+1,char);
6318 else retpath = __pathify_retbuf;
6319 strncpy(retpath, trndir, retlen-1);
6320 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6321 retpath[retlen-1] = '/'; /* with '/', add it. */
6322 retpath[retlen] = '\0';
6324 else retpath[retlen-1] = '\0';
6326 else { /* VMS-style directory spec */
6327 char *esa, *esal, *cp;
6330 unsigned long int sts, cmplen, haslower;
6331 struct FAB dirfab = cc$rms_fab;
6333 rms_setup_nam(savnam);
6334 rms_setup_nam(dirnam);
6336 /* If we've got an explicit filename, we can just shuffle the string. */
6337 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6338 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
6339 if ((cp2 = strchr(cp1,'.')) != NULL) {
6341 if (vms_process_case_tolerant) {
6342 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6343 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6344 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6345 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6346 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6347 (ver || *cp3)))))) {
6348 PerlMem_free(trndir);
6350 set_vaxc_errno(RMS$_DIR);
6355 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6356 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6357 !*(cp2+3) || *(cp2+3) != 'R' ||
6358 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6359 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6360 (ver || *cp3)))))) {
6361 PerlMem_free(trndir);
6363 set_vaxc_errno(RMS$_DIR);
6368 else { /* No file type, so just draw name into directory part */
6369 for (cp2 = cp1; *cp2; cp2++) ;
6372 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
6374 /* We've now got a VMS 'path'; fall through */
6377 dirlen = strlen(trndir);
6378 if (trndir[dirlen-1] == ']' ||
6379 trndir[dirlen-1] == '>' ||
6380 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6381 if (buf) retpath = buf;
6382 else if (ts) Newx(retpath,strlen(trndir)+1,char);
6383 else retpath = __pathify_retbuf;
6384 strcpy(retpath,trndir);
6385 PerlMem_free(trndir);
6388 rms_set_fna(dirfab, dirnam, trndir, dirlen);
6389 esa = PerlMem_malloc(VMS_MAXRSS);
6390 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
6392 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6393 esal = PerlMem_malloc(VMS_MAXRSS);
6394 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
6396 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6397 rms_bind_fab_nam(dirfab, dirnam);
6398 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
6399 #ifdef NAM$M_NO_SHORT_UPCASE
6400 if (decc_efs_case_preserve)
6401 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6404 for (cp = trndir; *cp; cp++)
6405 if (islower(*cp)) { haslower = 1; break; }
6407 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6408 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6409 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6410 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6413 PerlMem_free(trndir);
6418 set_vaxc_errno(dirfab.fab$l_sts);
6424 /* Does the file really exist? */
6425 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6426 if (dirfab.fab$l_sts != RMS$_FNF) {
6428 sts1 = rms_free_search_context(&dirfab);
6429 PerlMem_free(trndir);
6434 set_vaxc_errno(dirfab.fab$l_sts);
6437 dirnam = savnam; /* No; just work with potential name */
6440 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6441 /* Yep; check version while we're at it, if it's there. */
6442 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6443 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6445 /* Something other than .DIR[;1]. Bzzt. */
6446 sts2 = rms_free_search_context(&dirfab);
6447 PerlMem_free(trndir);
6452 set_vaxc_errno(RMS$_DIR);
6456 /* Make sure we are using the right buffer */
6458 /* We only need one, clean up the other */
6460 my_esa_len = rms_nam_esll(dirnam);
6463 my_esa_len = rms_nam_esl(dirnam);
6466 /* Null terminate the buffer */
6467 my_esa[my_esa_len] = '\0';
6469 /* OK, the type was fine. Now pull any file name into the
6471 if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6473 cp1 = strrchr(my_esa,'>');
6474 *(rms_nam_typel(dirnam)) = '>';
6477 *(rms_nam_typel(dirnam) + 1) = '\0';
6478 retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
6479 if (buf) retpath = buf;
6480 else if (ts) Newx(retpath,retlen,char);
6481 else retpath = __pathify_retbuf;
6482 strcpy(retpath,my_esa);
6486 sts = rms_free_search_context(&dirfab);
6487 /* $PARSE may have upcased filespec, so convert output to lower
6488 * case if input contained any lowercase characters. */
6489 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6492 PerlMem_free(trndir);
6494 } /* end of do_pathify_dirspec() */
6496 /* External entry points */
6497 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6498 { return do_pathify_dirspec(dir,buf,0,NULL); }
6499 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6500 { return do_pathify_dirspec(dir,buf,1,NULL); }
6501 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6502 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6503 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6504 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6506 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6507 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6509 static char __tounixspec_retbuf[VMS_MAXRSS];
6510 char *dirend, *rslt, *cp1, *cp3, *tmp;
6512 int devlen, dirlen, retlen = VMS_MAXRSS;
6513 int expand = 1; /* guarantee room for leading and trailing slashes */
6514 unsigned short int trnlnm_iter_count;
6516 if (utf8_fl != NULL)
6519 if (spec == NULL) return NULL;
6520 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6521 if (buf) rslt = buf;
6523 Newx(rslt, VMS_MAXRSS, char);
6525 else rslt = __tounixspec_retbuf;
6527 /* New VMS specific format needs translation
6528 * glob passes filenames with trailing '\n' and expects this preserved.
6530 if (decc_posix_compliant_pathnames) {
6531 if (strncmp(spec, "\"^UP^", 5) == 0) {
6537 tunix = PerlMem_malloc(VMS_MAXRSS);
6538 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
6539 strcpy(tunix, spec);
6540 tunix_len = strlen(tunix);
6542 if (tunix[tunix_len - 1] == '\n') {
6543 tunix[tunix_len - 1] = '\"';
6544 tunix[tunix_len] = '\0';
6548 uspec = decc$translate_vms(tunix);
6549 PerlMem_free(tunix);
6550 if ((int)uspec > 0) {
6556 /* If we can not translate it, makemaker wants as-is */
6564 cmp_rslt = 0; /* Presume VMS */
6565 cp1 = strchr(spec, '/');
6569 /* Look for EFS ^/ */
6570 if (decc_efs_charset) {
6571 while (cp1 != NULL) {
6574 /* Found illegal VMS, assume UNIX */
6579 cp1 = strchr(cp1, '/');
6583 /* Look for "." and ".." */
6584 if (decc_filename_unix_report) {
6585 if (spec[0] == '.') {
6586 if ((spec[1] == '\0') || (spec[1] == '\n')) {
6590 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6596 /* This is already UNIX or at least nothing VMS understands */
6604 dirend = strrchr(spec,']');
6605 if (dirend == NULL) dirend = strrchr(spec,'>');
6606 if (dirend == NULL) dirend = strchr(spec,':');
6607 if (dirend == NULL) {
6612 /* Special case 1 - sys$posix_root = / */
6613 #if __CRTL_VER >= 70000000
6614 if (!decc_disable_posix_root) {
6615 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6623 /* Special case 2 - Convert NLA0: to /dev/null */
6624 #if __CRTL_VER < 70000000
6625 cmp_rslt = strncmp(spec,"NLA0:", 5);
6627 cmp_rslt = strncmp(spec,"nla0:", 5);
6629 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6631 if (cmp_rslt == 0) {
6632 strcpy(rslt, "/dev/null");
6635 if (spec[6] != '\0') {
6642 /* Also handle special case "SYS$SCRATCH:" */
6643 #if __CRTL_VER < 70000000
6644 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6646 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6648 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6650 tmp = PerlMem_malloc(VMS_MAXRSS);
6651 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6652 if (cmp_rslt == 0) {
6655 islnm = my_trnlnm(tmp, "TMP", 0);
6657 strcpy(rslt, "/tmp");
6660 if (spec[12] != '\0') {
6668 if (*cp2 != '[' && *cp2 != '<') {
6671 else { /* the VMS spec begins with directories */
6673 if (*cp2 == ']' || *cp2 == '>') {
6674 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6678 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6679 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6680 if (ts) Safefree(rslt);
6684 trnlnm_iter_count = 0;
6687 while (*cp3 != ':' && *cp3) cp3++;
6689 if (strchr(cp3,']') != NULL) break;
6690 trnlnm_iter_count++;
6691 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6692 } while (vmstrnenv(tmp,tmp,0,fildev,0));
6694 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6695 retlen = devlen + dirlen;
6696 Renew(rslt,retlen+1+2*expand,char);
6702 *(cp1++) = *(cp3++);
6703 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6705 return NULL; /* No room */
6710 if ((*cp2 == '^')) {
6711 /* EFS file escape, pass the next character as is */
6712 /* Fix me: HEX encoding for Unicode not implemented */
6715 else if ( *cp2 == '.') {
6716 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6717 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6724 for (; cp2 <= dirend; cp2++) {
6725 if ((*cp2 == '^')) {
6726 /* EFS file escape, pass the next character as is */
6727 /* Fix me: HEX encoding for Unicode not implemented */
6728 *(cp1++) = *(++cp2);
6729 /* An escaped dot stays as is -- don't convert to slash */
6730 if (*cp2 == '.') cp2++;
6734 if (*(cp2+1) == '[') cp2++;
6736 else if (*cp2 == ']' || *cp2 == '>') {
6737 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6739 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6741 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6742 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6743 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6744 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6745 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6747 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6748 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6752 else if (*cp2 == '-') {
6753 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6754 while (*cp2 == '-') {
6756 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6758 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6759 if (ts) Safefree(rslt); /* filespecs like */
6760 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
6764 else *(cp1++) = *cp2;
6766 else *(cp1++) = *cp2;
6769 if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */
6770 *(cp1++) = *(cp2++);
6774 /* This still leaves /000000/ when working with a
6775 * VMS device root or concealed root.
6781 ulen = strlen(rslt);
6783 /* Get rid of "000000/ in rooted filespecs */
6785 zeros = strstr(rslt, "/000000/");
6786 if (zeros != NULL) {
6788 mlen = ulen - (zeros - rslt) - 7;
6789 memmove(zeros, &zeros[7], mlen);
6798 } /* end of do_tounixspec() */
6800 /* External entry points */
6801 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6802 { return do_tounixspec(spec,buf,0, NULL); }
6803 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6804 { return do_tounixspec(spec,buf,1, NULL); }
6805 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6806 { return do_tounixspec(spec,buf,0, utf8_fl); }
6807 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6808 { return do_tounixspec(spec,buf,1, utf8_fl); }
6810 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6813 This procedure is used to identify if a path is based in either
6814 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6815 it returns the OpenVMS format directory for it.
6817 It is expecting specifications of only '/' or '/xxxx/'
6819 If a posix root does not exist, or 'xxxx' is not a directory
6820 in the posix root, it returns a failure.
6822 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6824 It is used only internally by posix_to_vmsspec_hardway().
6827 static int posix_root_to_vms
6828 (char *vmspath, int vmspath_len,
6829 const char *unixpath,
6830 const int * utf8_fl)
6833 struct FAB myfab = cc$rms_fab;
6834 rms_setup_nam(mynam);
6835 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6836 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6837 char * esa, * esal, * rsa, * rsal;
6844 unixlen = strlen(unixpath);
6849 #if __CRTL_VER >= 80200000
6850 /* If not a posix spec already, convert it */
6851 if (decc_posix_compliant_pathnames) {
6852 if (strncmp(unixpath,"\"^UP^",5) != 0) {
6853 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6856 /* This is already a VMS specification, no conversion */
6858 strncpy(vmspath,unixpath, vmspath_len);
6867 /* Check to see if this is under the POSIX root */
6868 if (decc_disable_posix_root) {
6872 /* Skip leading / */
6873 if (unixpath[0] == '/') {
6879 strcpy(vmspath,"SYS$POSIX_ROOT:");
6881 /* If this is only the / , or blank, then... */
6882 if (unixpath[0] == '\0') {
6883 /* by definition, this is the answer */
6887 /* Need to look up a directory */
6891 /* Copy and add '^' escape characters as needed */
6894 while (unixpath[i] != 0) {
6897 j += copy_expand_unix_filename_escape
6898 (&vmspath[j], &unixpath[i], &k, utf8_fl);
6902 path_len = strlen(vmspath);
6903 if (vmspath[path_len - 1] == '/')
6905 vmspath[path_len] = ']';
6907 vmspath[path_len] = '\0';
6910 vmspath[vmspath_len] = 0;
6911 if (unixpath[unixlen - 1] == '/')
6913 esal = PerlMem_malloc(VMS_MAXRSS);
6914 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6915 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6916 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6917 rsal = PerlMem_malloc(VMS_MAXRSS);
6918 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6919 rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6920 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6921 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
6922 rms_bind_fab_nam(myfab, mynam);
6923 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
6924 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
6925 if (decc_efs_case_preserve)
6926 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6927 #ifdef NAML$M_OPEN_SPECIAL
6928 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6931 /* Set up the remaining naml fields */
6932 sts = sys$parse(&myfab);
6934 /* It failed! Try again as a UNIX filespec */
6943 /* get the Device ID and the FID */
6944 sts = sys$search(&myfab);
6946 /* These are no longer needed */
6951 /* on any failure, returned the POSIX ^UP^ filespec */
6956 specdsc.dsc$a_pointer = vmspath;
6957 specdsc.dsc$w_length = vmspath_len;
6959 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6960 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6961 sts = lib$fid_to_name
6962 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6964 /* on any failure, returned the POSIX ^UP^ filespec */
6966 /* This can happen if user does not have permission to read directories */
6967 if (strncmp(unixpath,"\"^UP^",5) != 0)
6968 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6970 strcpy(vmspath, unixpath);
6973 vmspath[specdsc.dsc$w_length] = 0;
6975 /* Are we expecting a directory? */
6976 if (dir_flag != 0) {
6982 i = specdsc.dsc$w_length - 1;
6986 /* Version must be '1' */
6987 if (vmspath[i--] != '1')
6989 /* Version delimiter is one of ".;" */
6990 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6993 if (vmspath[i--] != 'R')
6995 if (vmspath[i--] != 'I')
6997 if (vmspath[i--] != 'D')
6999 if (vmspath[i--] != '.')
7001 eptr = &vmspath[i+1];
7003 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7004 if (vmspath[i-1] != '^') {
7012 /* Get rid of 6 imaginary zero directory filename */
7013 vmspath[i+1] = '\0';
7017 if (vmspath[i] == '0')
7031 /* /dev/mumble needs to be handled special.
7032 /dev/null becomes NLA0:, And there is the potential for other stuff
7033 like /dev/tty which may need to be mapped to something.
7037 slash_dev_special_to_vms
7038 (const char * unixptr,
7048 nextslash = strchr(unixptr, '/');
7049 len = strlen(unixptr);
7050 if (nextslash != NULL)
7051 len = nextslash - unixptr;
7052 cmp = strncmp("null", unixptr, 5);
7054 if (vmspath_len >= 6) {
7055 strcpy(vmspath, "_NLA0:");
7062 /* The built in routines do not understand perl's special needs, so
7063 doing a manual conversion from UNIX to VMS
7065 If the utf8_fl is not null and points to a non-zero value, then
7066 treat 8 bit characters as UTF-8.
7068 The sequence starting with '$(' and ending with ')' will be passed
7069 through with out interpretation instead of being escaped.
7072 static int posix_to_vmsspec_hardway
7073 (char *vmspath, int vmspath_len,
7074 const char *unixpath,
7079 const char *unixptr;
7080 const char *unixend;
7082 const char *lastslash;
7083 const char *lastdot;
7089 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7090 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7092 if (utf8_fl != NULL)
7098 /* Ignore leading "/" characters */
7099 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7102 unixlen = strlen(unixptr);
7104 /* Do nothing with blank paths */
7111 /* This could have a "^UP^ on the front */
7112 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7118 lastslash = strrchr(unixptr,'/');
7119 lastdot = strrchr(unixptr,'.');
7120 unixend = strrchr(unixptr,'\"');
7121 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7122 unixend = unixptr + unixlen;
7125 /* last dot is last dot or past end of string */
7126 if (lastdot == NULL)
7127 lastdot = unixptr + unixlen;
7129 /* if no directories, set last slash to beginning of string */
7130 if (lastslash == NULL) {
7131 lastslash = unixptr;
7134 /* Watch out for trailing "." after last slash, still a directory */
7135 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7136 lastslash = unixptr + unixlen;
7139 /* Watch out for traiing ".." after last slash, still a directory */
7140 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7141 lastslash = unixptr + unixlen;
7144 /* dots in directories are aways escaped */
7145 if (lastdot < lastslash)
7146 lastdot = unixptr + unixlen;
7149 /* if (unixptr < lastslash) then we are in a directory */
7156 /* Start with the UNIX path */
7157 if (*unixptr != '/') {
7158 /* relative paths */
7160 /* If allowing logical names on relative pathnames, then handle here */
7161 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7162 !decc_posix_compliant_pathnames) {
7168 /* Find the next slash */
7169 nextslash = strchr(unixptr,'/');
7171 esa = PerlMem_malloc(vmspath_len);
7172 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7174 trn = PerlMem_malloc(VMS_MAXRSS);
7175 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7177 if (nextslash != NULL) {
7179 seg_len = nextslash - unixptr;
7180 strncpy(esa, unixptr, seg_len);
7184 strcpy(esa, unixptr);
7185 seg_len = strlen(unixptr);
7187 /* trnlnm(section) */
7188 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7191 /* Now fix up the directory */
7193 /* Split up the path to find the components */
7194 sts = vms_split_path
7213 /* A logical name must be a directory or the full
7214 specification. It is only a full specification if
7215 it is the only component */
7216 if ((unixptr[seg_len] == '\0') ||
7217 (unixptr[seg_len+1] == '\0')) {
7219 /* Is a directory being required? */
7220 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7221 /* Not a logical name */
7226 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7227 /* This must be a directory */
7228 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7229 strcpy(vmsptr, esa);
7230 vmslen=strlen(vmsptr);
7231 vmsptr[vmslen] = ':';
7233 vmsptr[vmslen] = '\0';
7241 /* must be dev/directory - ignore version */
7242 if ((n_len + e_len) != 0)
7245 /* transfer the volume */
7246 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7247 strncpy(vmsptr, v_spec, v_len);
7253 /* unroot the rooted directory */
7254 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7256 r_spec[r_len - 1] = ']';
7258 /* This should not be there, but nothing is perfect */
7260 cmp = strcmp(&r_spec[1], "000000.");
7270 strncpy(vmsptr, r_spec, r_len);
7276 /* Bring over the directory. */
7278 ((d_len + vmslen) < vmspath_len)) {
7280 d_spec[d_len - 1] = ']';
7282 cmp = strcmp(&d_spec[1], "000000.");
7293 /* Remove the redundant root */
7301 strncpy(vmsptr, d_spec, d_len);
7315 if (lastslash > unixptr) {
7318 /* skip leading ./ */
7320 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7326 /* Are we still in a directory? */
7327 if (unixptr <= lastslash) {
7332 /* if not backing up, then it is relative forward. */
7333 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7334 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7342 /* Perl wants an empty directory here to tell the difference
7343 * between a DCL commmand and a filename
7352 /* Handle two special files . and .. */
7353 if (unixptr[0] == '.') {
7354 if (&unixptr[1] == unixend) {
7361 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7372 else { /* Absolute PATH handling */
7376 /* Need to find out where root is */
7378 /* In theory, this procedure should never get an absolute POSIX pathname
7379 * that can not be found on the POSIX root.
7380 * In practice, that can not be relied on, and things will show up
7381 * here that are a VMS device name or concealed logical name instead.
7382 * So to make things work, this procedure must be tolerant.
7384 esa = PerlMem_malloc(vmspath_len);
7385 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7388 nextslash = strchr(&unixptr[1],'/');
7390 if (nextslash != NULL) {
7392 seg_len = nextslash - &unixptr[1];
7393 strncpy(vmspath, unixptr, seg_len + 1);
7394 vmspath[seg_len+1] = 0;
7397 cmp = strncmp(vmspath, "dev", 4);
7399 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7400 if (sts = SS$_NORMAL)
7404 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7407 if ($VMS_STATUS_SUCCESS(sts)) {
7408 /* This is verified to be a real path */
7410 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7411 if ($VMS_STATUS_SUCCESS(sts)) {
7412 strcpy(vmspath, esa);
7413 vmslen = strlen(vmspath);
7414 vmsptr = vmspath + vmslen;
7416 if (unixptr < lastslash) {
7425 cmp = strcmp(rptr,"000000.");
7430 } /* removing 6 zeros */
7431 } /* vmslen < 7, no 6 zeros possible */
7432 } /* Not in a directory */
7433 } /* Posix root found */
7435 /* No posix root, fall back to default directory */
7436 strcpy(vmspath, "SYS$DISK:[");
7437 vmsptr = &vmspath[10];
7439 if (unixptr > lastslash) {
7448 } /* end of verified real path handling */
7453 /* Ok, we have a device or a concealed root that is not in POSIX
7454 * or we have garbage. Make the best of it.
7457 /* Posix to VMS destroyed this, so copy it again */
7458 strncpy(vmspath, &unixptr[1], seg_len);
7459 vmspath[seg_len] = 0;
7461 vmsptr = &vmsptr[vmslen];
7464 /* Now do we need to add the fake 6 zero directory to it? */
7466 if ((*lastslash == '/') && (nextslash < lastslash)) {
7467 /* No there is another directory */
7474 /* now we have foo:bar or foo:[000000]bar to decide from */
7475 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7477 if (!islnm && !decc_posix_compliant_pathnames) {
7479 cmp = strncmp("bin", vmspath, 4);
7481 /* bin => SYS$SYSTEM: */
7482 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7485 /* tmp => SYS$SCRATCH: */
7486 cmp = strncmp("tmp", vmspath, 4);
7488 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7493 trnend = islnm ? islnm - 1 : 0;
7495 /* if this was a logical name, ']' or '>' must be present */
7496 /* if not a logical name, then assume a device and hope. */
7497 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7499 /* if log name and trailing '.' then rooted - treat as device */
7500 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7502 /* Fix me, if not a logical name, a device lookup should be
7503 * done to see if the device is file structured. If the device
7504 * is not file structured, the 6 zeros should not be put on.
7506 * As it is, perl is occasionally looking for dev:[000000]tty.
7507 * which looks a little strange.
7509 * Not that easy to detect as "/dev" may be file structured with
7510 * special device files.
7513 if ((add_6zero == 0) && (*nextslash == '/') &&
7514 (&nextslash[1] == unixend)) {
7515 /* No real directory present */
7520 /* Put the device delimiter on */
7523 unixptr = nextslash;
7526 /* Start directory if needed */
7527 if (!islnm || add_6zero) {
7533 /* add fake 000000] if needed */
7546 } /* non-POSIX translation */
7548 } /* End of relative/absolute path handling */
7550 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7557 if (dir_start != 0) {
7559 /* First characters in a directory are handled special */
7560 while ((*unixptr == '/') ||
7561 ((*unixptr == '.') &&
7562 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7563 (&unixptr[1]==unixend)))) {
7568 /* Skip redundant / in specification */
7569 while ((*unixptr == '/') && (dir_start != 0)) {
7572 if (unixptr == lastslash)
7575 if (unixptr == lastslash)
7578 /* Skip redundant ./ characters */
7579 while ((*unixptr == '.') &&
7580 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7583 if (unixptr == lastslash)
7585 if (*unixptr == '/')
7588 if (unixptr == lastslash)
7591 /* Skip redundant ../ characters */
7592 while ((*unixptr == '.') && (unixptr[1] == '.') &&
7593 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7594 /* Set the backing up flag */
7600 unixptr++; /* first . */
7601 unixptr++; /* second . */
7602 if (unixptr == lastslash)
7604 if (*unixptr == '/') /* The slash */
7607 if (unixptr == lastslash)
7610 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7611 /* Not needed when VMS is pretending to be UNIX. */
7613 /* Is this loop stuck because of too many dots? */
7614 if (loop_flag == 0) {
7615 /* Exit the loop and pass the rest through */
7620 /* Are we done with directories yet? */
7621 if (unixptr >= lastslash) {
7623 /* Watch out for trailing dots */
7632 if (*unixptr == '/')
7636 /* Have we stopped backing up? */
7641 /* dir_start continues to be = 1 */
7643 if (*unixptr == '-') {
7645 *vmsptr++ = *unixptr++;
7649 /* Now are we done with directories yet? */
7650 if (unixptr >= lastslash) {
7652 /* Watch out for trailing dots */
7668 if (unixptr >= unixend)
7671 /* Normal characters - More EFS work probably needed */
7677 /* remove multiple / */
7678 while (unixptr[1] == '/') {
7681 if (unixptr == lastslash) {
7682 /* Watch out for trailing dots */
7694 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7695 /* Not needed when VMS is pretending to be UNIX. */
7699 if (unixptr != unixend)
7704 if ((unixptr < lastdot) || (unixptr < lastslash) ||
7705 (&unixptr[1] == unixend)) {
7711 /* trailing dot ==> '^..' on VMS */
7712 if (unixptr == unixend) {
7720 *vmsptr++ = *unixptr++;
7724 if (quoted && (&unixptr[1] == unixend)) {
7728 in_cnt = copy_expand_unix_filename_escape
7729 (vmsptr, unixptr, &out_cnt, utf8_fl);
7739 in_cnt = copy_expand_unix_filename_escape
7740 (vmsptr, unixptr, &out_cnt, utf8_fl);
7747 /* Make sure directory is closed */
7748 if (unixptr == lastslash) {
7750 vmsptr2 = vmsptr - 1;
7752 if (*vmsptr2 != ']') {
7755 /* directories do not end in a dot bracket */
7756 if (*vmsptr2 == '.') {
7760 if (*vmsptr2 != '^') {
7761 vmsptr--; /* back up over the dot */
7769 /* Add a trailing dot if a file with no extension */
7770 vmsptr2 = vmsptr - 1;
7772 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7773 (*vmsptr2 != ')') && (*lastdot != '.')) {
7784 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7785 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7790 /* If a UTF8 flag is being passed, honor it */
7792 if (utf8_fl != NULL) {
7793 utf8_flag = *utf8_fl;
7798 /* If there is a possibility of UTF8, then if any UTF8 characters
7799 are present, then they must be converted to VTF-7
7801 result = strcpy(rslt, path); /* FIX-ME */
7804 result = strcpy(rslt, path);
7810 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7811 static char *mp_do_tovmsspec
7812 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7813 static char __tovmsspec_retbuf[VMS_MAXRSS];
7814 char *rslt, *dirend;
7819 unsigned long int infront = 0, hasdir = 1;
7822 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7823 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7825 if (path == NULL) return NULL;
7826 rslt_len = VMS_MAXRSS-1;
7827 if (buf) rslt = buf;
7828 else if (ts) Newx(rslt, VMS_MAXRSS, char);
7829 else rslt = __tovmsspec_retbuf;
7831 /* '.' and '..' are "[]" and "[-]" for a quick check */
7832 if (path[0] == '.') {
7833 if (path[1] == '\0') {
7835 if (utf8_flag != NULL)
7840 if (path[1] == '.' && path[2] == '\0') {
7842 if (utf8_flag != NULL)
7849 /* Posix specifications are now a native VMS format */
7850 /*--------------------------------------------------*/
7851 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7852 if (decc_posix_compliant_pathnames) {
7853 if (strncmp(path,"\"^UP^",5) == 0) {
7854 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7860 /* This is really the only way to see if this is already in VMS format */
7861 sts = vms_split_path
7876 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7877 replacement, because the above parse just took care of most of
7878 what is needed to do vmspath when the specification is already
7881 And if it is not already, it is easier to do the conversion as
7882 part of this routine than to call this routine and then work on
7886 /* If VMS punctuation was found, it is already VMS format */
7887 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7888 if (utf8_flag != NULL)
7893 /* Now, what to do with trailing "." cases where there is no
7894 extension? If this is a UNIX specification, and EFS characters
7895 are enabled, then the trailing "." should be converted to a "^.".
7896 But if this was already a VMS specification, then it should be
7899 So in the case of ambiguity, leave the specification alone.
7903 /* If there is a possibility of UTF8, then if any UTF8 characters
7904 are present, then they must be converted to VTF-7
7906 if (utf8_flag != NULL)
7912 dirend = strrchr(path,'/');
7914 if (dirend == NULL) {
7915 /* If we get here with no UNIX directory delimiters, then this is
7916 not a complete file specification, either garbage a UNIX glob
7917 specification that can not be converted to a VMS wildcard, or
7918 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7919 so apparently other programs expect this also.
7921 utf8 flag setting needs to be preserved.
7927 /* If POSIX mode active, handle the conversion */
7928 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7929 if (decc_efs_charset) {
7930 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7935 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
7936 if (!*(dirend+2)) dirend +=2;
7937 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7938 if (decc_efs_charset == 0) {
7939 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7945 lastdot = strrchr(cp2,'.');
7951 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7953 if (decc_disable_posix_root) {
7954 strcpy(rslt,"sys$disk:[000000]");
7957 strcpy(rslt,"sys$posix_root:[000000]");
7959 if (utf8_flag != NULL)
7963 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7965 trndev = PerlMem_malloc(VMS_MAXRSS);
7966 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7967 islnm = my_trnlnm(rslt,trndev,0);
7969 /* DECC special handling */
7971 if (strcmp(rslt,"bin") == 0) {
7972 strcpy(rslt,"sys$system");
7975 islnm = my_trnlnm(rslt,trndev,0);
7977 else if (strcmp(rslt,"tmp") == 0) {
7978 strcpy(rslt,"sys$scratch");
7981 islnm = my_trnlnm(rslt,trndev,0);
7983 else if (!decc_disable_posix_root) {
7984 strcpy(rslt, "sys$posix_root");
7988 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7989 islnm = my_trnlnm(rslt,trndev,0);
7991 else if (strcmp(rslt,"dev") == 0) {
7992 if (strncmp(cp2,"/null", 5) == 0) {
7993 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7994 strcpy(rslt,"NLA0");
7998 islnm = my_trnlnm(rslt,trndev,0);
8004 trnend = islnm ? strlen(trndev) - 1 : 0;
8005 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8006 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8007 /* If the first element of the path is a logical name, determine
8008 * whether it has to be translated so we can add more directories. */
8009 if (!islnm || rooted) {
8012 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8016 if (cp2 != dirend) {
8017 strcpy(rslt,trndev);
8018 cp1 = rslt + trnend;
8025 if (decc_disable_posix_root) {
8031 PerlMem_free(trndev);
8036 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8037 cp2 += 2; /* skip over "./" - it's redundant */
8038 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8040 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8041 *(cp1++) = '-'; /* "../" --> "-" */
8044 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8045 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8046 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8047 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8050 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8051 /* Escape the extra dots in EFS file specifications */
8054 if (cp2 > dirend) cp2 = dirend;
8056 else *(cp1++) = '.';
8058 for (; cp2 < dirend; cp2++) {
8060 if (*(cp2-1) == '/') continue;
8061 if (*(cp1-1) != '.') *(cp1++) = '.';
8064 else if (!infront && *cp2 == '.') {
8065 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8066 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
8067 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8068 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8069 else if (*(cp1-2) == '[') *(cp1-1) = '-';
8070 else { /* back up over previous directory name */
8072 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8073 if (*(cp1-1) == '[') {
8074 memcpy(cp1,"000000.",7);
8079 if (cp2 == dirend) break;
8081 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8082 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8083 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8084 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8086 *(cp1++) = '.'; /* Simulate trailing '/' */
8087 cp2 += 2; /* for loop will incr this to == dirend */
8089 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8092 if (decc_efs_charset == 0)
8093 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8095 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8101 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
8103 if (decc_efs_charset == 0)
8110 else *(cp1++) = *cp2;
8114 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8115 if (hasdir) *(cp1++) = ']';
8116 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
8117 /* fixme for ODS5 */
8124 if (decc_efs_charset == 0)
8135 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8136 decc_readdir_dropdotnotype) {
8141 /* trailing dot ==> '^..' on VMS */
8148 *(cp1++) = *(cp2++);
8153 /* This could be a macro to be passed through */
8154 *(cp1++) = *(cp2++);
8156 const char * save_cp2;
8160 /* paranoid check */
8166 *(cp1++) = *(cp2++);
8167 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8168 *(cp1++) = *(cp2++);
8169 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8170 *(cp1++) = *(cp2++);
8173 *(cp1++) = *(cp2++);
8177 if (is_macro == 0) {
8178 /* Not really a macro - never mind */
8191 /* Don't escape again if following character is
8192 * already something we escape.
8194 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8195 *(cp1++) = *(cp2++);
8198 /* But otherwise fall through and escape it. */
8216 *(cp1++) = *(cp2++);
8219 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8220 * which is wrong. UNIX notation should be ".dir." unless
8221 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8222 * changing this behavior could break more things at this time.
8223 * efs character set effectively does not allow "." to be a version
8224 * delimiter as a further complication about changing this.
8226 if (decc_filename_unix_report != 0) {
8229 *(cp1++) = *(cp2++);
8232 *(cp1++) = *(cp2++);
8235 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8239 /* Fix me for "^]", but that requires making sure that you do
8240 * not back up past the start of the filename
8242 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8247 if (utf8_flag != NULL)
8251 } /* end of do_tovmsspec() */
8253 /* External entry points */
8254 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8255 { return do_tovmsspec(path,buf,0,NULL); }
8256 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8257 { return do_tovmsspec(path,buf,1,NULL); }
8258 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8259 { return do_tovmsspec(path,buf,0,utf8_fl); }
8260 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8261 { return do_tovmsspec(path,buf,1,utf8_fl); }
8263 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8264 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8265 static char __tovmspath_retbuf[VMS_MAXRSS];
8267 char *pathified, *vmsified, *cp;
8269 if (path == NULL) return NULL;
8270 pathified = PerlMem_malloc(VMS_MAXRSS);
8271 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8272 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8273 PerlMem_free(pathified);
8279 Newx(vmsified, VMS_MAXRSS, char);
8280 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8281 PerlMem_free(pathified);
8282 if (vmsified) Safefree(vmsified);
8285 PerlMem_free(pathified);
8290 vmslen = strlen(vmsified);
8291 Newx(cp,vmslen+1,char);
8292 memcpy(cp,vmsified,vmslen);
8298 strcpy(__tovmspath_retbuf,vmsified);
8300 return __tovmspath_retbuf;
8303 } /* end of do_tovmspath() */
8305 /* External entry points */
8306 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8307 { return do_tovmspath(path,buf,0, NULL); }
8308 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8309 { return do_tovmspath(path,buf,1, NULL); }
8310 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8311 { return do_tovmspath(path,buf,0,utf8_fl); }
8312 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8313 { return do_tovmspath(path,buf,1,utf8_fl); }
8316 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8317 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8318 static char __tounixpath_retbuf[VMS_MAXRSS];
8320 char *pathified, *unixified, *cp;
8322 if (path == NULL) return NULL;
8323 pathified = PerlMem_malloc(VMS_MAXRSS);
8324 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8325 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8326 PerlMem_free(pathified);
8332 Newx(unixified, VMS_MAXRSS, char);
8334 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8335 PerlMem_free(pathified);
8336 if (unixified) Safefree(unixified);
8339 PerlMem_free(pathified);
8344 unixlen = strlen(unixified);
8345 Newx(cp,unixlen+1,char);
8346 memcpy(cp,unixified,unixlen);
8348 Safefree(unixified);
8352 strcpy(__tounixpath_retbuf,unixified);
8353 Safefree(unixified);
8354 return __tounixpath_retbuf;
8357 } /* end of do_tounixpath() */
8359 /* External entry points */
8360 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8361 { return do_tounixpath(path,buf,0,NULL); }
8362 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8363 { return do_tounixpath(path,buf,1,NULL); }
8364 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8365 { return do_tounixpath(path,buf,0,utf8_fl); }
8366 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8367 { return do_tounixpath(path,buf,1,utf8_fl); }
8370 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
8372 *****************************************************************************
8374 * Copyright (C) 1989-1994, 2007 by *
8375 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
8377 * Permission is hereby granted for the reproduction of this software *
8378 * on condition that this copyright notice is included in source *
8379 * distributions of the software. The code may be modified and *
8380 * distributed under the same terms as Perl itself. *
8382 * 27-Aug-1994 Modified for inclusion in perl5 *
8383 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
8384 *****************************************************************************
8388 * getredirection() is intended to aid in porting C programs
8389 * to VMS (Vax-11 C). The native VMS environment does not support
8390 * '>' and '<' I/O redirection, or command line wild card expansion,
8391 * or a command line pipe mechanism using the '|' AND background
8392 * command execution '&'. All of these capabilities are provided to any
8393 * C program which calls this procedure as the first thing in the
8395 * The piping mechanism will probably work with almost any 'filter' type
8396 * of program. With suitable modification, it may useful for other
8397 * portability problems as well.
8399 * Author: Mark Pizzolato (mark AT infocomm DOT com)
8403 struct list_item *next;
8407 static void add_item(struct list_item **head,
8408 struct list_item **tail,
8412 static void mp_expand_wild_cards(pTHX_ char *item,
8413 struct list_item **head,
8414 struct list_item **tail,
8417 static int background_process(pTHX_ int argc, char **argv);
8419 static void pipe_and_fork(pTHX_ char **cmargv);
8421 /*{{{ void getredirection(int *ac, char ***av)*/
8423 mp_getredirection(pTHX_ int *ac, char ***av)
8425 * Process vms redirection arg's. Exit if any error is seen.
8426 * If getredirection() processes an argument, it is erased
8427 * from the vector. getredirection() returns a new argc and argv value.
8428 * In the event that a background command is requested (by a trailing "&"),
8429 * this routine creates a background subprocess, and simply exits the program.
8431 * Warning: do not try to simplify the code for vms. The code
8432 * presupposes that getredirection() is called before any data is
8433 * read from stdin or written to stdout.
8435 * Normal usage is as follows:
8441 * getredirection(&argc, &argv);
8445 int argc = *ac; /* Argument Count */
8446 char **argv = *av; /* Argument Vector */
8447 char *ap; /* Argument pointer */
8448 int j; /* argv[] index */
8449 int item_count = 0; /* Count of Items in List */
8450 struct list_item *list_head = 0; /* First Item in List */
8451 struct list_item *list_tail; /* Last Item in List */
8452 char *in = NULL; /* Input File Name */
8453 char *out = NULL; /* Output File Name */
8454 char *outmode = "w"; /* Mode to Open Output File */
8455 char *err = NULL; /* Error File Name */
8456 char *errmode = "w"; /* Mode to Open Error File */
8457 int cmargc = 0; /* Piped Command Arg Count */
8458 char **cmargv = NULL;/* Piped Command Arg Vector */
8461 * First handle the case where the last thing on the line ends with
8462 * a '&'. This indicates the desire for the command to be run in a
8463 * subprocess, so we satisfy that desire.
8466 if (0 == strcmp("&", ap))
8467 exit(background_process(aTHX_ --argc, argv));
8468 if (*ap && '&' == ap[strlen(ap)-1])
8470 ap[strlen(ap)-1] = '\0';
8471 exit(background_process(aTHX_ argc, argv));
8474 * Now we handle the general redirection cases that involve '>', '>>',
8475 * '<', and pipes '|'.
8477 for (j = 0; j < argc; ++j)
8479 if (0 == strcmp("<", argv[j]))
8483 fprintf(stderr,"No input file after < on command line");
8484 exit(LIB$_WRONUMARG);
8489 if ('<' == *(ap = argv[j]))
8494 if (0 == strcmp(">", ap))
8498 fprintf(stderr,"No output file after > on command line");
8499 exit(LIB$_WRONUMARG);
8518 fprintf(stderr,"No output file after > or >> on command line");
8519 exit(LIB$_WRONUMARG);
8523 if (('2' == *ap) && ('>' == ap[1]))
8540 fprintf(stderr,"No output file after 2> or 2>> on command line");
8541 exit(LIB$_WRONUMARG);
8545 if (0 == strcmp("|", argv[j]))
8549 fprintf(stderr,"No command into which to pipe on command line");
8550 exit(LIB$_WRONUMARG);
8552 cmargc = argc-(j+1);
8553 cmargv = &argv[j+1];
8557 if ('|' == *(ap = argv[j]))
8565 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8568 * Allocate and fill in the new argument vector, Some Unix's terminate
8569 * the list with an extra null pointer.
8571 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8572 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8574 for (j = 0; j < item_count; ++j, list_head = list_head->next)
8575 argv[j] = list_head->value;
8581 fprintf(stderr,"'|' and '>' may not both be specified on command line");
8582 exit(LIB$_INVARGORD);
8584 pipe_and_fork(aTHX_ cmargv);
8587 /* Check for input from a pipe (mailbox) */
8589 if (in == NULL && 1 == isapipe(0))
8591 char mbxname[L_tmpnam];
8593 long int dvi_item = DVI$_DEVBUFSIZ;
8594 $DESCRIPTOR(mbxnam, "");
8595 $DESCRIPTOR(mbxdevnam, "");
8597 /* Input from a pipe, reopen it in binary mode to disable */
8598 /* carriage control processing. */
8600 fgetname(stdin, mbxname);
8601 mbxnam.dsc$a_pointer = mbxname;
8602 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8603 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8604 mbxdevnam.dsc$a_pointer = mbxname;
8605 mbxdevnam.dsc$w_length = sizeof(mbxname);
8606 dvi_item = DVI$_DEVNAM;
8607 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8608 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8611 freopen(mbxname, "rb", stdin);
8614 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8618 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8620 fprintf(stderr,"Can't open input file %s as stdin",in);
8623 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8625 fprintf(stderr,"Can't open output file %s as stdout",out);
8628 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8631 if (strcmp(err,"&1") == 0) {
8632 dup2(fileno(stdout), fileno(stderr));
8633 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8636 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8638 fprintf(stderr,"Can't open error file %s as stderr",err);
8642 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8646 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8649 #ifdef ARGPROC_DEBUG
8650 PerlIO_printf(Perl_debug_log, "Arglist:\n");
8651 for (j = 0; j < *ac; ++j)
8652 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8654 /* Clear errors we may have hit expanding wildcards, so they don't
8655 show up in Perl's $! later */
8656 set_errno(0); set_vaxc_errno(1);
8657 } /* end of getredirection() */
8660 static void add_item(struct list_item **head,
8661 struct list_item **tail,
8667 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8668 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8672 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8673 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8674 *tail = (*tail)->next;
8676 (*tail)->value = value;
8680 static void mp_expand_wild_cards(pTHX_ char *item,
8681 struct list_item **head,
8682 struct list_item **tail,
8686 unsigned long int context = 0;
8694 $DESCRIPTOR(filespec, "");
8695 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8696 $DESCRIPTOR(resultspec, "");
8697 unsigned long int lff_flags = 0;
8701 #ifdef VMS_LONGNAME_SUPPORT
8702 lff_flags = LIB$M_FIL_LONG_NAMES;
8705 for (cp = item; *cp; cp++) {
8706 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8707 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8709 if (!*cp || isspace(*cp))
8711 add_item(head, tail, item, count);
8716 /* "double quoted" wild card expressions pass as is */
8717 /* From DCL that means using e.g.: */
8718 /* perl program """perl.*""" */
8719 item_len = strlen(item);
8720 if ( '"' == *item && '"' == item[item_len-1] )
8723 item[item_len-2] = '\0';
8724 add_item(head, tail, item, count);
8728 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8729 resultspec.dsc$b_class = DSC$K_CLASS_D;
8730 resultspec.dsc$a_pointer = NULL;
8731 vmsspec = PerlMem_malloc(VMS_MAXRSS);
8732 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8733 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8734 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8735 if (!isunix || !filespec.dsc$a_pointer)
8736 filespec.dsc$a_pointer = item;
8737 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8739 * Only return version specs, if the caller specified a version
8741 had_version = strchr(item, ';');
8743 * Only return device and directory specs, if the caller specifed either.
8745 had_device = strchr(item, ':');
8746 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8748 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8749 (&filespec, &resultspec, &context,
8750 &defaultspec, 0, &rms_sts, &lff_flags)))
8755 string = PerlMem_malloc(resultspec.dsc$w_length+1);
8756 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8757 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8758 string[resultspec.dsc$w_length] = '\0';
8759 if (NULL == had_version)
8760 *(strrchr(string, ';')) = '\0';
8761 if ((!had_directory) && (had_device == NULL))
8763 if (NULL == (devdir = strrchr(string, ']')))
8764 devdir = strrchr(string, '>');
8765 strcpy(string, devdir + 1);
8768 * Be consistent with what the C RTL has already done to the rest of
8769 * the argv items and lowercase all of these names.
8771 if (!decc_efs_case_preserve) {
8772 for (c = string; *c; ++c)
8776 if (isunix) trim_unixpath(string,item,1);
8777 add_item(head, tail, string, count);
8780 PerlMem_free(vmsspec);
8781 if (sts != RMS$_NMF)
8783 set_vaxc_errno(sts);
8786 case RMS$_FNF: case RMS$_DNF:
8787 set_errno(ENOENT); break;
8789 set_errno(ENOTDIR); break;
8791 set_errno(ENODEV); break;
8792 case RMS$_FNM: case RMS$_SYN:
8793 set_errno(EINVAL); break;
8795 set_errno(EACCES); break;
8797 _ckvmssts_noperl(sts);
8801 add_item(head, tail, item, count);
8802 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8803 _ckvmssts_noperl(lib$find_file_end(&context));
8806 static int child_st[2];/* Event Flag set when child process completes */
8808 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
8810 static unsigned long int exit_handler(int *status)
8814 if (0 == child_st[0])
8816 #ifdef ARGPROC_DEBUG
8817 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8819 fflush(stdout); /* Have to flush pipe for binary data to */
8820 /* terminate properly -- <tp@mccall.com> */
8821 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8822 sys$dassgn(child_chan);
8824 sys$synch(0, child_st);
8829 static void sig_child(int chan)
8831 #ifdef ARGPROC_DEBUG
8832 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8834 if (child_st[0] == 0)
8838 static struct exit_control_block exit_block =
8843 &exit_block.exit_status,
8848 pipe_and_fork(pTHX_ char **cmargv)
8851 struct dsc$descriptor_s *vmscmd;
8852 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8853 int sts, j, l, ismcr, quote, tquote = 0;
8855 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
8856 vms_execfree(vmscmd);
8861 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
8862 && toupper(*(q+2)) == 'R' && !*(q+3);
8864 while (q && l < MAX_DCL_LINE_LENGTH) {
8866 if (j > 0 && quote) {
8872 if (ismcr && j > 1) quote = 1;
8873 tquote = (strchr(q,' ')) != NULL || *q == '\0';
8876 if (quote || tquote) {
8882 if ((quote||tquote) && *q == '"') {
8892 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8894 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8898 static int background_process(pTHX_ int argc, char **argv)
8900 char command[MAX_DCL_SYMBOL + 1] = "$";
8901 $DESCRIPTOR(value, "");
8902 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8903 static $DESCRIPTOR(null, "NLA0:");
8904 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8906 $DESCRIPTOR(pidstr, "");
8908 unsigned long int flags = 17, one = 1, retsts;
8911 strcat(command, argv[0]);
8912 len = strlen(command);
8913 while (--argc && (len < MAX_DCL_SYMBOL))
8915 strcat(command, " \"");
8916 strcat(command, *(++argv));
8917 strcat(command, "\"");
8918 len = strlen(command);
8920 value.dsc$a_pointer = command;
8921 value.dsc$w_length = strlen(value.dsc$a_pointer);
8922 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8923 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8924 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8925 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8928 _ckvmssts_noperl(retsts);
8930 #ifdef ARGPROC_DEBUG
8931 PerlIO_printf(Perl_debug_log, "%s\n", command);
8933 sprintf(pidstring, "%08X", pid);
8934 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8935 pidstr.dsc$a_pointer = pidstring;
8936 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8937 lib$set_symbol(&pidsymbol, &pidstr);
8941 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8944 /* OS-specific initialization at image activation (not thread startup) */
8945 /* Older VAXC header files lack these constants */
8946 #ifndef JPI$_RIGHTS_SIZE
8947 # define JPI$_RIGHTS_SIZE 817
8949 #ifndef KGB$M_SUBSYSTEM
8950 # define KGB$M_SUBSYSTEM 0x8
8953 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8955 /*{{{void vms_image_init(int *, char ***)*/
8957 vms_image_init(int *argcp, char ***argvp)
8959 char eqv[LNM$C_NAMLENGTH+1] = "";
8960 unsigned int len, tabct = 8, tabidx = 0;
8961 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8962 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8963 unsigned short int dummy, rlen;
8964 struct dsc$descriptor_s **tabvec;
8965 #if defined(PERL_IMPLICIT_CONTEXT)
8968 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8969 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8970 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8973 #ifdef KILL_BY_SIGPRC
8974 Perl_csighandler_init();
8977 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8978 _ckvmssts_noperl(iosb[0]);
8979 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8980 if (iprv[i]) { /* Running image installed with privs? */
8981 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
8986 /* Rights identifiers might trigger tainting as well. */
8987 if (!will_taint && (rlen || rsz)) {
8988 while (rlen < rsz) {
8989 /* We didn't get all the identifiers on the first pass. Allocate a
8990 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8991 * were needed to hold all identifiers at time of last call; we'll
8992 * allocate that many unsigned long ints), and go back and get 'em.
8993 * If it gave us less than it wanted to despite ample buffer space,
8994 * something's broken. Is your system missing a system identifier?
8996 if (rsz <= jpilist[1].buflen) {
8997 /* Perl_croak accvios when used this early in startup. */
8998 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8999 rsz, (unsigned long) jpilist[1].buflen,
9000 "Check your rights database for corruption.\n");
9003 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9004 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9005 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9006 jpilist[1].buflen = rsz * sizeof(unsigned long int);
9007 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9008 _ckvmssts_noperl(iosb[0]);
9010 mask = jpilist[1].bufadr;
9011 /* Check attribute flags for each identifier (2nd longword); protected
9012 * subsystem identifiers trigger tainting.
9014 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9015 if (mask[i] & KGB$M_SUBSYSTEM) {
9020 if (mask != rlst) PerlMem_free(mask);
9023 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9024 * logical, some versions of the CRTL will add a phanthom /000000/
9025 * directory. This needs to be removed.
9027 if (decc_filename_unix_report) {
9030 ulen = strlen(argvp[0][0]);
9032 zeros = strstr(argvp[0][0], "/000000/");
9033 if (zeros != NULL) {
9035 mlen = ulen - (zeros - argvp[0][0]) - 7;
9036 memmove(zeros, &zeros[7], mlen);
9038 argvp[0][0][ulen] = '\0';
9041 /* It also may have a trailing dot that needs to be removed otherwise
9042 * it will be converted to VMS mode incorrectly.
9045 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9046 argvp[0][0][ulen] = '\0';
9049 /* We need to use this hack to tell Perl it should run with tainting,
9050 * since its tainting flag may be part of the PL_curinterp struct, which
9051 * hasn't been allocated when vms_image_init() is called.
9054 char **newargv, **oldargv;
9056 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9057 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9058 newargv[0] = oldargv[0];
9059 newargv[1] = PerlMem_malloc(3 * sizeof(char));
9060 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9061 strcpy(newargv[1], "-T");
9062 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9064 newargv[*argcp] = NULL;
9065 /* We orphan the old argv, since we don't know where it's come from,
9066 * so we don't know how to free it.
9070 else { /* Did user explicitly request tainting? */
9072 char *cp, **av = *argvp;
9073 for (i = 1; i < *argcp; i++) {
9074 if (*av[i] != '-') break;
9075 for (cp = av[i]+1; *cp; cp++) {
9076 if (*cp == 'T') { will_taint = 1; break; }
9077 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9078 strchr("DFIiMmx",*cp)) break;
9080 if (will_taint) break;
9085 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9088 tabvec = (struct dsc$descriptor_s **)
9089 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9090 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9092 else if (tabidx >= tabct) {
9094 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9095 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9097 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9098 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9099 tabvec[tabidx]->dsc$w_length = 0;
9100 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9101 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9102 tabvec[tabidx]->dsc$a_pointer = NULL;
9103 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9105 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9107 getredirection(argcp,argvp);
9108 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9110 # include <reentrancy.h>
9111 decc$set_reentrancy(C$C_MULTITHREAD);
9120 * Trim Unix-style prefix off filespec, so it looks like what a shell
9121 * glob expansion would return (i.e. from specified prefix on, not
9122 * full path). Note that returned filespec is Unix-style, regardless
9123 * of whether input filespec was VMS-style or Unix-style.
9125 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9126 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9127 * vector of options; at present, only bit 0 is used, and if set tells
9128 * trim unixpath to try the current default directory as a prefix when
9129 * presented with a possibly ambiguous ... wildcard.
9131 * Returns !=0 on success, with trimmed filespec replacing contents of
9132 * fspec, and 0 on failure, with contents of fpsec unchanged.
9134 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9136 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9138 char *unixified, *unixwild,
9139 *template, *base, *end, *cp1, *cp2;
9140 register int tmplen, reslen = 0, dirs = 0;
9142 unixwild = PerlMem_malloc(VMS_MAXRSS);
9143 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
9144 if (!wildspec || !fspec) return 0;
9145 template = unixwild;
9146 if (strpbrk(wildspec,"]>:") != NULL) {
9147 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
9148 PerlMem_free(unixwild);
9153 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9154 unixwild[VMS_MAXRSS-1] = 0;
9156 unixified = PerlMem_malloc(VMS_MAXRSS);
9157 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
9158 if (strpbrk(fspec,"]>:") != NULL) {
9159 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9160 PerlMem_free(unixwild);
9161 PerlMem_free(unixified);
9164 else base = unixified;
9165 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9166 * check to see that final result fits into (isn't longer than) fspec */
9167 reslen = strlen(fspec);
9171 /* No prefix or absolute path on wildcard, so nothing to remove */
9172 if (!*template || *template == '/') {
9173 PerlMem_free(unixwild);
9174 if (base == fspec) {
9175 PerlMem_free(unixified);
9178 tmplen = strlen(unixified);
9179 if (tmplen > reslen) {
9180 PerlMem_free(unixified);
9181 return 0; /* not enough space */
9183 /* Copy unixified resultant, including trailing NUL */
9184 memmove(fspec,unixified,tmplen+1);
9185 PerlMem_free(unixified);
9189 for (end = base; *end; end++) ; /* Find end of resultant filespec */
9190 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9191 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9192 for (cp1 = end ;cp1 >= base; cp1--)
9193 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9195 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9196 PerlMem_free(unixified);
9197 PerlMem_free(unixwild);
9202 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9203 int ells = 1, totells, segdirs, match;
9204 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9205 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9207 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9209 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9210 tpl = PerlMem_malloc(VMS_MAXRSS);
9211 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
9212 if (ellipsis == template && opts & 1) {
9213 /* Template begins with an ellipsis. Since we can't tell how many
9214 * directory names at the front of the resultant to keep for an
9215 * arbitrary starting point, we arbitrarily choose the current
9216 * default directory as a starting point. If it's there as a prefix,
9217 * clip it off. If not, fall through and act as if the leading
9218 * ellipsis weren't there (i.e. return shortest possible path that
9219 * could match template).
9221 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9223 PerlMem_free(unixified);
9224 PerlMem_free(unixwild);
9227 if (!decc_efs_case_preserve) {
9228 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9229 if (_tolower(*cp1) != _tolower(*cp2)) break;
9231 segdirs = dirs - totells; /* Min # of dirs we must have left */
9232 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9233 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9234 memmove(fspec,cp2+1,end - cp2);
9236 PerlMem_free(unixified);
9237 PerlMem_free(unixwild);
9241 /* First off, back up over constant elements at end of path */
9243 for (front = end ; front >= base; front--)
9244 if (*front == '/' && !dirs--) { front++; break; }
9246 lcres = PerlMem_malloc(VMS_MAXRSS);
9247 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
9248 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9250 if (!decc_efs_case_preserve) {
9251 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9259 PerlMem_free(unixified);
9260 PerlMem_free(unixwild);
9261 PerlMem_free(lcres);
9262 return 0; /* Path too long. */
9265 *cp2 = '\0'; /* Pick up with memcpy later */
9266 lcfront = lcres + (front - base);
9267 /* Now skip over each ellipsis and try to match the path in front of it. */
9269 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9270 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9271 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
9272 if (cp1 < template) break; /* template started with an ellipsis */
9273 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9274 ellipsis = cp1; continue;
9276 wilddsc.dsc$a_pointer = tpl;
9277 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9279 for (segdirs = 0, cp2 = tpl;
9280 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9282 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9284 if (!decc_efs_case_preserve) {
9285 *cp2 = _tolower(*cp1); /* else lowercase for match */
9288 *cp2 = *cp1; /* else preserve case for match */
9291 if (*cp2 == '/') segdirs++;
9293 if (cp1 != ellipsis - 1) {
9295 PerlMem_free(unixified);
9296 PerlMem_free(unixwild);
9297 PerlMem_free(lcres);
9298 return 0; /* Path too long */
9300 /* Back up at least as many dirs as in template before matching */
9301 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9302 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9303 for (match = 0; cp1 > lcres;) {
9304 resdsc.dsc$a_pointer = cp1;
9305 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9307 if (match == 1) lcfront = cp1;
9309 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9313 PerlMem_free(unixified);
9314 PerlMem_free(unixwild);
9315 PerlMem_free(lcres);
9316 return 0; /* Can't find prefix ??? */
9318 if (match > 1 && opts & 1) {
9319 /* This ... wildcard could cover more than one set of dirs (i.e.
9320 * a set of similar dir names is repeated). If the template
9321 * contains more than 1 ..., upstream elements could resolve the
9322 * ambiguity, but it's not worth a full backtracking setup here.
9323 * As a quick heuristic, clip off the current default directory
9324 * if it's present to find the trimmed spec, else use the
9325 * shortest string that this ... could cover.
9327 char def[NAM$C_MAXRSS+1], *st;
9329 if (getcwd(def, sizeof def,0) == NULL) {
9330 Safefree(unixified);
9336 if (!decc_efs_case_preserve) {
9337 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9338 if (_tolower(*cp1) != _tolower(*cp2)) break;
9340 segdirs = dirs - totells; /* Min # of dirs we must have left */
9341 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9342 if (*cp1 == '\0' && *cp2 == '/') {
9343 memmove(fspec,cp2+1,end - cp2);
9345 PerlMem_free(unixified);
9346 PerlMem_free(unixwild);
9347 PerlMem_free(lcres);
9350 /* Nope -- stick with lcfront from above and keep going. */
9353 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9355 PerlMem_free(unixified);
9356 PerlMem_free(unixwild);
9357 PerlMem_free(lcres);
9362 } /* end of trim_unixpath() */
9367 * VMS readdir() routines.
9368 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9370 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
9371 * Minor modifications to original routines.
9374 /* readdir may have been redefined by reentr.h, so make sure we get
9375 * the local version for what we do here.
9380 #if !defined(PERL_IMPLICIT_CONTEXT)
9381 # define readdir Perl_readdir
9383 # define readdir(a) Perl_readdir(aTHX_ a)
9386 /* Number of elements in vms_versions array */
9387 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
9390 * Open a directory, return a handle for later use.
9392 /*{{{ DIR *opendir(char*name) */
9394 Perl_opendir(pTHX_ const char *name)
9400 Newx(dir, VMS_MAXRSS, char);
9401 if (do_tovmspath(name,dir,0,NULL) == NULL) {
9405 /* Check access before stat; otherwise stat does not
9406 * accurately report whether it's a directory.
9408 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9409 /* cando_by_name has already set errno */
9413 if (flex_stat(dir,&sb) == -1) return NULL;
9414 if (!S_ISDIR(sb.st_mode)) {
9416 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
9419 /* Get memory for the handle, and the pattern. */
9421 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9423 /* Fill in the fields; mainly playing with the descriptor. */
9424 sprintf(dd->pattern, "%s*.*",dir);
9429 /* By saying we always want the result of readdir() in unix format, we
9430 * are really saying we want all the escapes removed. Otherwise the caller,
9431 * having no way to know whether it's already in VMS format, might send it
9432 * through tovmsspec again, thus double escaping.
9434 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9435 dd->pat.dsc$a_pointer = dd->pattern;
9436 dd->pat.dsc$w_length = strlen(dd->pattern);
9437 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9438 dd->pat.dsc$b_class = DSC$K_CLASS_S;
9439 #if defined(USE_ITHREADS)
9440 Newx(dd->mutex,1,perl_mutex);
9441 MUTEX_INIT( (perl_mutex *) dd->mutex );
9447 } /* end of opendir() */
9451 * Set the flag to indicate we want versions or not.
9453 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9455 vmsreaddirversions(DIR *dd, int flag)
9458 dd->flags |= PERL_VMSDIR_M_VERSIONS;
9460 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9465 * Free up an opened directory.
9467 /*{{{ void closedir(DIR *dd)*/
9469 Perl_closedir(DIR *dd)
9473 sts = lib$find_file_end(&dd->context);
9474 Safefree(dd->pattern);
9475 #if defined(USE_ITHREADS)
9476 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9477 Safefree(dd->mutex);
9484 * Collect all the version numbers for the current file.
9487 collectversions(pTHX_ DIR *dd)
9489 struct dsc$descriptor_s pat;
9490 struct dsc$descriptor_s res;
9492 char *p, *text, *buff;
9494 unsigned long context, tmpsts;
9496 /* Convenient shorthand. */
9499 /* Add the version wildcard, ignoring the "*.*" put on before */
9500 i = strlen(dd->pattern);
9501 Newx(text,i + e->d_namlen + 3,char);
9502 strcpy(text, dd->pattern);
9503 sprintf(&text[i - 3], "%s;*", e->d_name);
9505 /* Set up the pattern descriptor. */
9506 pat.dsc$a_pointer = text;
9507 pat.dsc$w_length = i + e->d_namlen - 1;
9508 pat.dsc$b_dtype = DSC$K_DTYPE_T;
9509 pat.dsc$b_class = DSC$K_CLASS_S;
9511 /* Set up result descriptor. */
9512 Newx(buff, VMS_MAXRSS, char);
9513 res.dsc$a_pointer = buff;
9514 res.dsc$w_length = VMS_MAXRSS - 1;
9515 res.dsc$b_dtype = DSC$K_DTYPE_T;
9516 res.dsc$b_class = DSC$K_CLASS_S;
9518 /* Read files, collecting versions. */
9519 for (context = 0, e->vms_verscount = 0;
9520 e->vms_verscount < VERSIZE(e);
9521 e->vms_verscount++) {
9523 unsigned long flags = 0;
9525 #ifdef VMS_LONGNAME_SUPPORT
9526 flags = LIB$M_FIL_LONG_NAMES;
9528 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9529 if (tmpsts == RMS$_NMF || context == 0) break;
9531 buff[VMS_MAXRSS - 1] = '\0';
9532 if ((p = strchr(buff, ';')))
9533 e->vms_versions[e->vms_verscount] = atoi(p + 1);
9535 e->vms_versions[e->vms_verscount] = -1;
9538 _ckvmssts(lib$find_file_end(&context));
9542 } /* end of collectversions() */
9545 * Read the next entry from the directory.
9547 /*{{{ struct dirent *readdir(DIR *dd)*/
9549 Perl_readdir(pTHX_ DIR *dd)
9551 struct dsc$descriptor_s res;
9553 unsigned long int tmpsts;
9555 unsigned long flags = 0;
9556 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9557 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9559 /* Set up result descriptor, and get next file. */
9560 Newx(buff, VMS_MAXRSS, char);
9561 res.dsc$a_pointer = buff;
9562 res.dsc$w_length = VMS_MAXRSS - 1;
9563 res.dsc$b_dtype = DSC$K_DTYPE_T;
9564 res.dsc$b_class = DSC$K_CLASS_S;
9566 #ifdef VMS_LONGNAME_SUPPORT
9567 flags = LIB$M_FIL_LONG_NAMES;
9570 tmpsts = lib$find_file
9571 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9572 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
9573 if (!(tmpsts & 1)) {
9574 set_vaxc_errno(tmpsts);
9577 set_errno(EACCES); break;
9579 set_errno(ENODEV); break;
9581 set_errno(ENOTDIR); break;
9582 case RMS$_FNF: case RMS$_DNF:
9583 set_errno(ENOENT); break;
9591 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9592 if (!decc_efs_case_preserve) {
9593 buff[VMS_MAXRSS - 1] = '\0';
9594 for (p = buff; *p; p++) *p = _tolower(*p);
9597 /* we don't want to force to lowercase, just null terminate */
9598 buff[res.dsc$w_length] = '\0';
9600 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
9603 /* Skip any directory component and just copy the name. */
9604 sts = vms_split_path
9619 /* Drop NULL extensions on UNIX file specification */
9620 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9621 (e_len == 1) && decc_readdir_dropdotnotype)) {
9626 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9627 dd->entry.d_name[n_len + e_len] = '\0';
9628 dd->entry.d_namlen = strlen(dd->entry.d_name);
9630 /* Convert the filename to UNIX format if needed */
9631 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9633 /* Translate the encoded characters. */
9634 /* Fixme: Unicode handling could result in embedded 0 characters */
9635 if (strchr(dd->entry.d_name, '^') != NULL) {
9638 p = dd->entry.d_name;
9641 int inchars_read, outchars_added;
9642 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9644 q += outchars_added;
9646 /* if outchars_added > 1, then this is a wide file specification */
9647 /* Wide file specifications need to be passed in Perl */
9648 /* counted strings apparently with a Unicode flag */
9651 strcpy(dd->entry.d_name, new_name);
9652 dd->entry.d_namlen = strlen(dd->entry.d_name);
9656 dd->entry.vms_verscount = 0;
9657 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9661 } /* end of readdir() */
9665 * Read the next entry from the directory -- thread-safe version.
9667 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9669 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9673 MUTEX_LOCK( (perl_mutex *) dd->mutex );
9675 entry = readdir(dd);
9677 retval = ( *result == NULL ? errno : 0 );
9679 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9683 } /* end of readdir_r() */
9687 * Return something that can be used in a seekdir later.
9689 /*{{{ long telldir(DIR *dd)*/
9691 Perl_telldir(DIR *dd)
9698 * Return to a spot where we used to be. Brute force.
9700 /*{{{ void seekdir(DIR *dd,long count)*/
9702 Perl_seekdir(pTHX_ DIR *dd, long count)
9706 /* If we haven't done anything yet... */
9710 /* Remember some state, and clear it. */
9711 old_flags = dd->flags;
9712 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9713 _ckvmssts(lib$find_file_end(&dd->context));
9716 /* The increment is in readdir(). */
9717 for (dd->count = 0; dd->count < count; )
9720 dd->flags = old_flags;
9722 } /* end of seekdir() */
9725 /* VMS subprocess management
9727 * my_vfork() - just a vfork(), after setting a flag to record that
9728 * the current script is trying a Unix-style fork/exec.
9730 * vms_do_aexec() and vms_do_exec() are called in response to the
9731 * perl 'exec' function. If this follows a vfork call, then they
9732 * call out the regular perl routines in doio.c which do an
9733 * execvp (for those who really want to try this under VMS).
9734 * Otherwise, they do exactly what the perl docs say exec should
9735 * do - terminate the current script and invoke a new command
9736 * (See below for notes on command syntax.)
9738 * do_aspawn() and do_spawn() implement the VMS side of the perl
9739 * 'system' function.
9741 * Note on command arguments to perl 'exec' and 'system': When handled
9742 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9743 * are concatenated to form a DCL command string. If the first non-numeric
9744 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
9745 * the command string is handed off to DCL directly. Otherwise,
9746 * the first token of the command is taken as the filespec of an image
9747 * to run. The filespec is expanded using a default type of '.EXE' and
9748 * the process defaults for device, directory, etc., and if found, the resultant
9749 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9750 * the command string as parameters. This is perhaps a bit complicated,
9751 * but I hope it will form a happy medium between what VMS folks expect
9752 * from lib$spawn and what Unix folks expect from exec.
9755 static int vfork_called;
9757 /*{{{int my_vfork()*/
9768 vms_execfree(struct dsc$descriptor_s *vmscmd)
9771 if (vmscmd->dsc$a_pointer) {
9772 PerlMem_free(vmscmd->dsc$a_pointer);
9774 PerlMem_free(vmscmd);
9779 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9781 char *junk, *tmps = Nullch;
9782 register size_t cmdlen = 0;
9789 tmps = SvPV(really,rlen);
9796 for (idx++; idx <= sp; idx++) {
9798 junk = SvPVx(*idx,rlen);
9799 cmdlen += rlen ? rlen + 1 : 0;
9802 Newx(PL_Cmd, cmdlen+1, char);
9804 if (tmps && *tmps) {
9805 strcpy(PL_Cmd,tmps);
9808 else *PL_Cmd = '\0';
9809 while (++mark <= sp) {
9811 char *s = SvPVx(*mark,n_a);
9813 if (*PL_Cmd) strcat(PL_Cmd," ");
9819 } /* end of setup_argstr() */
9822 static unsigned long int
9823 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9824 struct dsc$descriptor_s **pvmscmd)
9826 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9827 char image_name[NAM$C_MAXRSS+1];
9828 char image_argv[NAM$C_MAXRSS+1];
9829 $DESCRIPTOR(defdsc,".EXE");
9830 $DESCRIPTOR(defdsc2,".");
9831 $DESCRIPTOR(resdsc,resspec);
9832 struct dsc$descriptor_s *vmscmd;
9833 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9834 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9835 register char *s, *rest, *cp, *wordbreak;
9840 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9841 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9843 /* Make a copy for modification */
9844 cmdlen = strlen(incmd);
9845 cmd = PerlMem_malloc(cmdlen+1);
9846 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9847 strncpy(cmd, incmd, cmdlen);
9852 vmscmd->dsc$a_pointer = NULL;
9853 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
9854 vmscmd->dsc$b_class = DSC$K_CLASS_S;
9855 vmscmd->dsc$w_length = 0;
9856 if (pvmscmd) *pvmscmd = vmscmd;
9858 if (suggest_quote) *suggest_quote = 0;
9860 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9862 return CLI$_BUFOVF; /* continuation lines currently unsupported */
9867 while (*s && isspace(*s)) s++;
9869 if (*s == '@' || *s == '$') {
9870 vmsspec[0] = *s; rest = s + 1;
9871 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9873 else { cp = vmsspec; rest = s; }
9874 if (*rest == '.' || *rest == '/') {
9877 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9878 rest++, cp2++) *cp2 = *rest;
9880 if (do_tovmsspec(resspec,cp,0,NULL)) {
9883 for (cp2 = vmsspec + strlen(vmsspec);
9884 *rest && cp2 - vmsspec < sizeof vmsspec;
9885 rest++, cp2++) *cp2 = *rest;
9890 /* Intuit whether verb (first word of cmd) is a DCL command:
9891 * - if first nonspace char is '@', it's a DCL indirection
9893 * - if verb contains a filespec separator, it's not a DCL command
9894 * - if it doesn't, caller tells us whether to default to a DCL
9895 * command, or to a local image unless told it's DCL (by leading '$')
9899 if (suggest_quote) *suggest_quote = 1;
9901 register char *filespec = strpbrk(s,":<[.;");
9902 rest = wordbreak = strpbrk(s," \"\t/");
9903 if (!wordbreak) wordbreak = s + strlen(s);
9904 if (*s == '$') check_img = 0;
9905 if (filespec && (filespec < wordbreak)) isdcl = 0;
9906 else isdcl = !check_img;
9911 imgdsc.dsc$a_pointer = s;
9912 imgdsc.dsc$w_length = wordbreak - s;
9913 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9915 _ckvmssts(lib$find_file_end(&cxt));
9916 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9917 if (!(retsts & 1) && *s == '$') {
9918 _ckvmssts(lib$find_file_end(&cxt));
9919 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9920 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9922 _ckvmssts(lib$find_file_end(&cxt));
9923 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9927 _ckvmssts(lib$find_file_end(&cxt));
9932 while (*s && !isspace(*s)) s++;
9935 /* check that it's really not DCL with no file extension */
9936 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9938 char b[256] = {0,0,0,0};
9939 read(fileno(fp), b, 256);
9940 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9944 /* Check for script */
9946 if ((b[0] == '#') && (b[1] == '!'))
9948 #ifdef ALTERNATE_SHEBANG
9950 shebang_len = strlen(ALTERNATE_SHEBANG);
9951 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9953 perlstr = strstr("perl",b);
9954 if (perlstr == NULL)
9962 if (shebang_len > 0) {
9965 char tmpspec[NAM$C_MAXRSS + 1];
9968 /* Image is following after white space */
9969 /*--------------------------------------*/
9970 while (isprint(b[i]) && isspace(b[i]))
9974 while (isprint(b[i]) && !isspace(b[i])) {
9975 tmpspec[j++] = b[i++];
9976 if (j >= NAM$C_MAXRSS)
9981 /* There may be some default parameters to the image */
9982 /*---------------------------------------------------*/
9984 while (isprint(b[i])) {
9985 image_argv[j++] = b[i++];
9986 if (j >= NAM$C_MAXRSS)
9989 while ((j > 0) && !isprint(image_argv[j-1]))
9993 /* It will need to be converted to VMS format and validated */
9994 if (tmpspec[0] != '\0') {
9997 /* Try to find the exact program requested to be run */
9998 /*---------------------------------------------------*/
9999 iname = do_rmsexpand
10000 (tmpspec, image_name, 0, ".exe",
10001 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10002 if (iname != NULL) {
10003 if (cando_by_name_int
10004 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10005 /* MCR prefix needed */
10009 /* Try again with a null type */
10010 /*----------------------------*/
10011 iname = do_rmsexpand
10012 (tmpspec, image_name, 0, ".",
10013 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10014 if (iname != NULL) {
10015 if (cando_by_name_int
10016 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10017 /* MCR prefix needed */
10023 /* Did we find the image to run the script? */
10024 /*------------------------------------------*/
10028 /* Assume DCL or foreign command exists */
10029 /*--------------------------------------*/
10030 tchr = strrchr(tmpspec, '/');
10031 if (tchr != NULL) {
10037 strcpy(image_name, tchr);
10045 if (check_img && isdcl) return RMS$_FNF;
10047 if (cando_by_name(S_IXUSR,0,resspec)) {
10048 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10049 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10051 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10052 if (image_name[0] != 0) {
10053 strcat(vmscmd->dsc$a_pointer, image_name);
10054 strcat(vmscmd->dsc$a_pointer, " ");
10056 } else if (image_name[0] != 0) {
10057 strcpy(vmscmd->dsc$a_pointer, image_name);
10058 strcat(vmscmd->dsc$a_pointer, " ");
10060 strcpy(vmscmd->dsc$a_pointer,"@");
10062 if (suggest_quote) *suggest_quote = 1;
10064 /* If there is an image name, use original command */
10065 if (image_name[0] == 0)
10066 strcat(vmscmd->dsc$a_pointer,resspec);
10069 while (*rest && isspace(*rest)) rest++;
10072 if (image_argv[0] != 0) {
10073 strcat(vmscmd->dsc$a_pointer,image_argv);
10074 strcat(vmscmd->dsc$a_pointer, " ");
10080 rest_len = strlen(rest);
10081 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10082 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10083 strcat(vmscmd->dsc$a_pointer,rest);
10085 retsts = CLI$_BUFOVF;
10087 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10089 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10095 /* It's either a DCL command or we couldn't find a suitable image */
10096 vmscmd->dsc$w_length = strlen(cmd);
10098 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10099 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10100 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10104 /* check if it's a symbol (for quoting purposes) */
10105 if (suggest_quote && !*suggest_quote) {
10107 char equiv[LNM$C_NAMLENGTH];
10108 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10109 eqvdsc.dsc$a_pointer = equiv;
10111 iss = lib$get_symbol(vmscmd,&eqvdsc);
10112 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10114 if (!(retsts & 1)) {
10115 /* just hand off status values likely to be due to user error */
10116 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10117 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10118 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10119 else { _ckvmssts(retsts); }
10122 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10124 } /* end of setup_cmddsc() */
10127 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10129 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10135 if (vfork_called) { /* this follows a vfork - act Unixish */
10137 if (vfork_called < 0) {
10138 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10141 else return do_aexec(really,mark,sp);
10143 /* no vfork - act VMSish */
10144 cmd = setup_argstr(aTHX_ really,mark,sp);
10145 exec_sts = vms_do_exec(cmd);
10146 Safefree(cmd); /* Clean up from setup_argstr() */
10151 } /* end of vms_do_aexec() */
10154 /* {{{bool vms_do_exec(char *cmd) */
10156 Perl_vms_do_exec(pTHX_ const char *cmd)
10158 struct dsc$descriptor_s *vmscmd;
10160 if (vfork_called) { /* this follows a vfork - act Unixish */
10162 if (vfork_called < 0) {
10163 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10166 else return do_exec(cmd);
10169 { /* no vfork - act VMSish */
10170 unsigned long int retsts;
10173 TAINT_PROPER("exec");
10174 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10175 retsts = lib$do_command(vmscmd);
10178 case RMS$_FNF: case RMS$_DNF:
10179 set_errno(ENOENT); break;
10181 set_errno(ENOTDIR); break;
10183 set_errno(ENODEV); break;
10185 set_errno(EACCES); break;
10187 set_errno(EINVAL); break;
10188 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10189 set_errno(E2BIG); break;
10190 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10191 _ckvmssts(retsts); /* fall through */
10192 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10193 set_errno(EVMSERR);
10195 set_vaxc_errno(retsts);
10196 if (ckWARN(WARN_EXEC)) {
10197 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10198 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10200 vms_execfree(vmscmd);
10205 } /* end of vms_do_exec() */
10208 unsigned long int Perl_do_spawn(pTHX_ const char *);
10209 unsigned long int do_spawn2(pTHX_ const char *, int);
10211 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
10213 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
10215 unsigned long int sts;
10221 /* We'll copy the (undocumented?) Win32 behavior and allow a
10222 * numeric first argument. But the only value we'll support
10223 * through do_aspawn is a value of 1, which means spawn without
10224 * waiting for completion -- other values are ignored.
10226 if (SvNIOKp(*((SV**)mark+1)) && !SvPOKp(*((SV**)mark+1))) {
10228 flags = SvIVx(*(SV**)mark);
10231 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
10232 flags = CLI$M_NOWAIT;
10236 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
10237 sts = do_spawn2(aTHX_ cmd, flags);
10238 /* pp_sys will clean up cmd */
10242 } /* end of do_aspawn() */
10246 /* {{{unsigned long int do_spawn(char *cmd) */
10248 Perl_do_spawn(pTHX_ const char *cmd)
10250 return do_spawn2(aTHX_ cmd, 0);
10254 /* {{{unsigned long int do_spawn2(char *cmd) */
10256 do_spawn2(pTHX_ const char *cmd, int flags)
10258 unsigned long int sts, substs;
10260 /* The caller of this routine expects to Safefree(PL_Cmd) */
10261 Newx(PL_Cmd,10,char);
10264 TAINT_PROPER("spawn");
10265 if (!cmd || !*cmd) {
10266 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10269 case RMS$_FNF: case RMS$_DNF:
10270 set_errno(ENOENT); break;
10272 set_errno(ENOTDIR); break;
10274 set_errno(ENODEV); break;
10276 set_errno(EACCES); break;
10278 set_errno(EINVAL); break;
10279 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10280 set_errno(E2BIG); break;
10281 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10282 _ckvmssts(sts); /* fall through */
10283 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10284 set_errno(EVMSERR);
10286 set_vaxc_errno(sts);
10287 if (ckWARN(WARN_EXEC)) {
10288 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10297 if (flags & CLI$M_NOWAIT)
10300 strcpy(mode, "nW");
10302 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10305 /* sts will be the pid in the nowait case */
10308 } /* end of do_spawn2() */
10312 static unsigned int *sockflags, sockflagsize;
10315 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10316 * routines found in some versions of the CRTL can't deal with sockets.
10317 * We don't shim the other file open routines since a socket isn't
10318 * likely to be opened by a name.
10320 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10321 FILE *my_fdopen(int fd, const char *mode)
10323 FILE *fp = fdopen(fd, mode);
10326 unsigned int fdoff = fd / sizeof(unsigned int);
10327 Stat_t sbuf; /* native stat; we don't need flex_stat */
10328 if (!sockflagsize || fdoff > sockflagsize) {
10329 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
10330 else Newx (sockflags,fdoff+2,unsigned int);
10331 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10332 sockflagsize = fdoff + 2;
10334 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10335 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10344 * Clear the corresponding bit when the (possibly) socket stream is closed.
10345 * There still a small hole: we miss an implicit close which might occur
10346 * via freopen(). >> Todo
10348 /*{{{ int my_fclose(FILE *fp)*/
10349 int my_fclose(FILE *fp) {
10351 unsigned int fd = fileno(fp);
10352 unsigned int fdoff = fd / sizeof(unsigned int);
10354 if (sockflagsize && fdoff <= sockflagsize)
10355 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10363 * A simple fwrite replacement which outputs itmsz*nitm chars without
10364 * introducing record boundaries every itmsz chars.
10365 * We are using fputs, which depends on a terminating null. We may
10366 * well be writing binary data, so we need to accommodate not only
10367 * data with nulls sprinkled in the middle but also data with no null
10370 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10372 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10374 register char *cp, *end, *cpd, *data;
10375 register unsigned int fd = fileno(dest);
10376 register unsigned int fdoff = fd / sizeof(unsigned int);
10378 int bufsize = itmsz * nitm + 1;
10380 if (fdoff < sockflagsize &&
10381 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10382 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10386 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10387 memcpy( data, src, itmsz*nitm );
10388 data[itmsz*nitm] = '\0';
10390 end = data + itmsz * nitm;
10391 retval = (int) nitm; /* on success return # items written */
10394 while (cpd <= end) {
10395 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10396 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10398 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10402 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10405 } /* end of my_fwrite() */
10408 /*{{{ int my_flush(FILE *fp)*/
10410 Perl_my_flush(pTHX_ FILE *fp)
10413 if ((res = fflush(fp)) == 0 && fp) {
10414 #ifdef VMS_DO_SOCKETS
10416 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
10418 res = fsync(fileno(fp));
10421 * If the flush succeeded but set end-of-file, we need to clear
10422 * the error because our caller may check ferror(). BTW, this
10423 * probably means we just flushed an empty file.
10425 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10432 * Here are replacements for the following Unix routines in the VMS environment:
10433 * getpwuid Get information for a particular UIC or UID
10434 * getpwnam Get information for a named user
10435 * getpwent Get information for each user in the rights database
10436 * setpwent Reset search to the start of the rights database
10437 * endpwent Finish searching for users in the rights database
10439 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10440 * (defined in pwd.h), which contains the following fields:-
10442 * char *pw_name; Username (in lower case)
10443 * char *pw_passwd; Hashed password
10444 * unsigned int pw_uid; UIC
10445 * unsigned int pw_gid; UIC group number
10446 * char *pw_unixdir; Default device/directory (VMS-style)
10447 * char *pw_gecos; Owner name
10448 * char *pw_dir; Default device/directory (Unix-style)
10449 * char *pw_shell; Default CLI name (eg. DCL)
10451 * If the specified user does not exist, getpwuid and getpwnam return NULL.
10453 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10454 * not the UIC member number (eg. what's returned by getuid()),
10455 * getpwuid() can accept either as input (if uid is specified, the caller's
10456 * UIC group is used), though it won't recognise gid=0.
10458 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10459 * information about other users in your group or in other groups, respectively.
10460 * If the required privilege is not available, then these routines fill only
10461 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10464 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10467 /* sizes of various UAF record fields */
10468 #define UAI$S_USERNAME 12
10469 #define UAI$S_IDENT 31
10470 #define UAI$S_OWNER 31
10471 #define UAI$S_DEFDEV 31
10472 #define UAI$S_DEFDIR 63
10473 #define UAI$S_DEFCLI 31
10474 #define UAI$S_PWD 8
10476 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
10477 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10478 (uic).uic$v_group != UIC$K_WILD_GROUP)
10480 static char __empty[]= "";
10481 static struct passwd __passwd_empty=
10482 {(char *) __empty, (char *) __empty, 0, 0,
10483 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10484 static int contxt= 0;
10485 static struct passwd __pwdcache;
10486 static char __pw_namecache[UAI$S_IDENT+1];
10489 * This routine does most of the work extracting the user information.
10491 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10494 unsigned char length;
10495 char pw_gecos[UAI$S_OWNER+1];
10497 static union uicdef uic;
10499 unsigned char length;
10500 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10503 unsigned char length;
10504 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10507 unsigned char length;
10508 char pw_shell[UAI$S_DEFCLI+1];
10510 static char pw_passwd[UAI$S_PWD+1];
10512 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10513 struct dsc$descriptor_s name_desc;
10514 unsigned long int sts;
10516 static struct itmlst_3 itmlst[]= {
10517 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
10518 {sizeof(uic), UAI$_UIC, &uic, &luic},
10519 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
10520 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
10521 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
10522 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
10523 {0, 0, NULL, NULL}};
10525 name_desc.dsc$w_length= strlen(name);
10526 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10527 name_desc.dsc$b_class= DSC$K_CLASS_S;
10528 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10530 /* Note that sys$getuai returns many fields as counted strings. */
10531 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10532 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10533 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10535 else { _ckvmssts(sts); }
10536 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
10538 if ((int) owner.length < lowner) lowner= (int) owner.length;
10539 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10540 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10541 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10542 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10543 owner.pw_gecos[lowner]= '\0';
10544 defdev.pw_dir[ldefdev+ldefdir]= '\0';
10545 defcli.pw_shell[ldefcli]= '\0';
10546 if (valid_uic(uic)) {
10547 pwd->pw_uid= uic.uic$l_uic;
10548 pwd->pw_gid= uic.uic$v_group;
10551 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10552 pwd->pw_passwd= pw_passwd;
10553 pwd->pw_gecos= owner.pw_gecos;
10554 pwd->pw_dir= defdev.pw_dir;
10555 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10556 pwd->pw_shell= defcli.pw_shell;
10557 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10559 ldir= strlen(pwd->pw_unixdir) - 1;
10560 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10563 strcpy(pwd->pw_unixdir, pwd->pw_dir);
10564 if (!decc_efs_case_preserve)
10565 __mystrtolower(pwd->pw_unixdir);
10570 * Get information for a named user.
10572 /*{{{struct passwd *getpwnam(char *name)*/
10573 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10575 struct dsc$descriptor_s name_desc;
10577 unsigned long int status, sts;
10579 __pwdcache = __passwd_empty;
10580 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10581 /* We still may be able to determine pw_uid and pw_gid */
10582 name_desc.dsc$w_length= strlen(name);
10583 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10584 name_desc.dsc$b_class= DSC$K_CLASS_S;
10585 name_desc.dsc$a_pointer= (char *) name;
10586 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10587 __pwdcache.pw_uid= uic.uic$l_uic;
10588 __pwdcache.pw_gid= uic.uic$v_group;
10591 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10592 set_vaxc_errno(sts);
10593 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10596 else { _ckvmssts(sts); }
10599 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10600 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10601 __pwdcache.pw_name= __pw_namecache;
10602 return &__pwdcache;
10603 } /* end of my_getpwnam() */
10607 * Get information for a particular UIC or UID.
10608 * Called by my_getpwent with uid=-1 to list all users.
10610 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10611 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10613 const $DESCRIPTOR(name_desc,__pw_namecache);
10614 unsigned short lname;
10616 unsigned long int status;
10618 if (uid == (unsigned int) -1) {
10620 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10621 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10622 set_vaxc_errno(status);
10623 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10627 else { _ckvmssts(status); }
10628 } while (!valid_uic (uic));
10631 uic.uic$l_uic= uid;
10632 if (!uic.uic$v_group)
10633 uic.uic$v_group= PerlProc_getgid();
10634 if (valid_uic(uic))
10635 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10636 else status = SS$_IVIDENT;
10637 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10638 status == RMS$_PRV) {
10639 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10642 else { _ckvmssts(status); }
10644 __pw_namecache[lname]= '\0';
10645 __mystrtolower(__pw_namecache);
10647 __pwdcache = __passwd_empty;
10648 __pwdcache.pw_name = __pw_namecache;
10650 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10651 The identifier's value is usually the UIC, but it doesn't have to be,
10652 so if we can, we let fillpasswd update this. */
10653 __pwdcache.pw_uid = uic.uic$l_uic;
10654 __pwdcache.pw_gid = uic.uic$v_group;
10656 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10657 return &__pwdcache;
10659 } /* end of my_getpwuid() */
10663 * Get information for next user.
10665 /*{{{struct passwd *my_getpwent()*/
10666 struct passwd *Perl_my_getpwent(pTHX)
10668 return (my_getpwuid((unsigned int) -1));
10673 * Finish searching rights database for users.
10675 /*{{{void my_endpwent()*/
10676 void Perl_my_endpwent(pTHX)
10679 _ckvmssts(sys$finish_rdb(&contxt));
10685 #ifdef HOMEGROWN_POSIX_SIGNALS
10686 /* Signal handling routines, pulled into the core from POSIX.xs.
10688 * We need these for threads, so they've been rolled into the core,
10689 * rather than left in POSIX.xs.
10691 * (DRS, Oct 23, 1997)
10694 /* sigset_t is atomic under VMS, so these routines are easy */
10695 /*{{{int my_sigemptyset(sigset_t *) */
10696 int my_sigemptyset(sigset_t *set) {
10697 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10698 *set = 0; return 0;
10703 /*{{{int my_sigfillset(sigset_t *)*/
10704 int my_sigfillset(sigset_t *set) {
10706 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10707 for (i = 0; i < NSIG; i++) *set |= (1 << i);
10713 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10714 int my_sigaddset(sigset_t *set, int sig) {
10715 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10716 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10717 *set |= (1 << (sig - 1));
10723 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10724 int my_sigdelset(sigset_t *set, int sig) {
10725 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10726 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10727 *set &= ~(1 << (sig - 1));
10733 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10734 int my_sigismember(sigset_t *set, int sig) {
10735 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10736 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10737 return *set & (1 << (sig - 1));
10742 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10743 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10746 /* If set and oset are both null, then things are badly wrong. Bail out. */
10747 if ((oset == NULL) && (set == NULL)) {
10748 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10752 /* If set's null, then we're just handling a fetch. */
10754 tempmask = sigblock(0);
10759 tempmask = sigsetmask(*set);
10762 tempmask = sigblock(*set);
10765 tempmask = sigblock(0);
10766 sigsetmask(*oset & ~tempmask);
10769 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10774 /* Did they pass us an oset? If so, stick our holding mask into it */
10781 #endif /* HOMEGROWN_POSIX_SIGNALS */
10784 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10785 * my_utime(), and flex_stat(), all of which operate on UTC unless
10786 * VMSISH_TIMES is true.
10788 /* method used to handle UTC conversions:
10789 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
10791 static int gmtime_emulation_type;
10792 /* number of secs to add to UTC POSIX-style time to get local time */
10793 static long int utc_offset_secs;
10795 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10796 * in vmsish.h. #undef them here so we can call the CRTL routines
10805 * DEC C previous to 6.0 corrupts the behavior of the /prefix
10806 * qualifier with the extern prefix pragma. This provisional
10807 * hack circumvents this prefix pragma problem in previous
10810 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10811 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10812 # pragma __extern_prefix save
10813 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
10814 # define gmtime decc$__utctz_gmtime
10815 # define localtime decc$__utctz_localtime
10816 # define time decc$__utc_time
10817 # pragma __extern_prefix restore
10819 struct tm *gmtime(), *localtime();
10825 static time_t toutc_dst(time_t loc) {
10828 if ((rsltmp = localtime(&loc)) == NULL) return -1;
10829 loc -= utc_offset_secs;
10830 if (rsltmp->tm_isdst) loc -= 3600;
10833 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10834 ((gmtime_emulation_type || my_time(NULL)), \
10835 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10836 ((secs) - utc_offset_secs))))
10838 static time_t toloc_dst(time_t utc) {
10841 utc += utc_offset_secs;
10842 if ((rsltmp = localtime(&utc)) == NULL) return -1;
10843 if (rsltmp->tm_isdst) utc += 3600;
10846 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10847 ((gmtime_emulation_type || my_time(NULL)), \
10848 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10849 ((secs) + utc_offset_secs))))
10851 #ifndef RTL_USES_UTC
10854 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
10855 DST starts on 1st sun of april at 02:00 std time
10856 ends on last sun of october at 02:00 dst time
10857 see the UCX management command reference, SET CONFIG TIMEZONE
10858 for formatting info.
10860 No, it's not as general as it should be, but then again, NOTHING
10861 will handle UK times in a sensible way.
10866 parse the DST start/end info:
10867 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10871 tz_parse_startend(char *s, struct tm *w, int *past)
10873 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10874 int ly, dozjd, d, m, n, hour, min, sec, j, k;
10879 if (!past) return 0;
10882 if (w->tm_year % 4 == 0) ly = 1;
10883 if (w->tm_year % 100 == 0) ly = 0;
10884 if (w->tm_year+1900 % 400 == 0) ly = 1;
10887 dozjd = isdigit(*s);
10888 if (*s == 'J' || *s == 'j' || dozjd) {
10889 if (!dozjd && !isdigit(*++s)) return 0;
10892 d = d*10 + *s++ - '0';
10894 d = d*10 + *s++ - '0';
10897 if (d == 0) return 0;
10898 if (d > 366) return 0;
10900 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
10903 } else if (*s == 'M' || *s == 'm') {
10904 if (!isdigit(*++s)) return 0;
10906 if (isdigit(*s)) m = 10*m + *s++ - '0';
10907 if (*s != '.') return 0;
10908 if (!isdigit(*++s)) return 0;
10910 if (n < 1 || n > 5) return 0;
10911 if (*s != '.') return 0;
10912 if (!isdigit(*++s)) return 0;
10914 if (d > 6) return 0;
10918 if (!isdigit(*++s)) return 0;
10920 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10922 if (!isdigit(*++s)) return 0;
10924 if (isdigit(*s)) min = 10*min + *s++ - '0';
10926 if (!isdigit(*++s)) return 0;
10928 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10938 if (w->tm_yday < d) goto before;
10939 if (w->tm_yday > d) goto after;
10941 if (w->tm_mon+1 < m) goto before;
10942 if (w->tm_mon+1 > m) goto after;
10944 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
10945 k = d - j; /* mday of first d */
10946 if (k <= 0) k += 7;
10947 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
10948 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10949 if (w->tm_mday < k) goto before;
10950 if (w->tm_mday > k) goto after;
10953 if (w->tm_hour < hour) goto before;
10954 if (w->tm_hour > hour) goto after;
10955 if (w->tm_min < min) goto before;
10956 if (w->tm_min > min) goto after;
10957 if (w->tm_sec < sec) goto before;
10971 /* parse the offset: (+|-)hh[:mm[:ss]] */
10974 tz_parse_offset(char *s, int *offset)
10976 int hour = 0, min = 0, sec = 0;
10979 if (!offset) return 0;
10981 if (*s == '-') {neg++; s++;}
10982 if (*s == '+') s++;
10983 if (!isdigit(*s)) return 0;
10985 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10986 if (hour > 24) return 0;
10988 if (!isdigit(*++s)) return 0;
10990 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10991 if (min > 59) return 0;
10993 if (!isdigit(*++s)) return 0;
10995 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10996 if (sec > 59) return 0;
11000 *offset = (hour*60+min)*60 + sec;
11001 if (neg) *offset = -*offset;
11006 input time is w, whatever type of time the CRTL localtime() uses.
11007 sets dst, the zone, and the gmtoff (seconds)
11009 caches the value of TZ and UCX$TZ env variables; note that
11010 my_setenv looks for these and sets a flag if they're changed
11013 We have to watch out for the "australian" case (dst starts in
11014 october, ends in april)...flagged by "reverse" and checked by
11015 scanning through the months of the previous year.
11020 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11025 char *dstzone, *tz, *s_start, *s_end;
11026 int std_off, dst_off, isdst;
11027 int y, dststart, dstend;
11028 static char envtz[1025]; /* longer than any logical, symbol, ... */
11029 static char ucxtz[1025];
11030 static char reversed = 0;
11036 reversed = -1; /* flag need to check */
11037 envtz[0] = ucxtz[0] = '\0';
11038 tz = my_getenv("TZ",0);
11039 if (tz) strcpy(envtz, tz);
11040 tz = my_getenv("UCX$TZ",0);
11041 if (tz) strcpy(ucxtz, tz);
11042 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
11045 if (!*tz) tz = ucxtz;
11048 while (isalpha(*s)) s++;
11049 s = tz_parse_offset(s, &std_off);
11051 if (!*s) { /* no DST, hurray we're done! */
11057 while (isalpha(*s)) s++;
11058 s2 = tz_parse_offset(s, &dst_off);
11062 dst_off = std_off - 3600;
11065 if (!*s) { /* default dst start/end?? */
11066 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
11067 s = strchr(ucxtz,',');
11069 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
11071 if (*s != ',') return 0;
11074 when = _toutc(when); /* convert to utc */
11075 when = when - std_off; /* convert to pseudolocal time*/
11077 w2 = localtime(&when);
11080 s = tz_parse_startend(s_start,w2,&dststart);
11082 if (*s != ',') return 0;
11085 when = _toutc(when); /* convert to utc */
11086 when = when - dst_off; /* convert to pseudolocal time*/
11087 w2 = localtime(&when);
11088 if (w2->tm_year != y) { /* spans a year, just check one time */
11089 when += dst_off - std_off;
11090 w2 = localtime(&when);
11093 s = tz_parse_startend(s_end,w2,&dstend);
11096 if (reversed == -1) { /* need to check if start later than end */
11100 if (when < 2*365*86400) {
11101 when += 2*365*86400;
11105 w2 =localtime(&when);
11106 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
11108 for (j = 0; j < 12; j++) {
11109 w2 =localtime(&when);
11110 tz_parse_startend(s_start,w2,&ds);
11111 tz_parse_startend(s_end,w2,&de);
11112 if (ds != de) break;
11116 if (de && !ds) reversed = 1;
11119 isdst = dststart && !dstend;
11120 if (reversed) isdst = dststart || !dstend;
11123 if (dst) *dst = isdst;
11124 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11125 if (isdst) tz = dstzone;
11127 while(isalpha(*tz)) *zone++ = *tz++;
11133 #endif /* !RTL_USES_UTC */
11135 /* my_time(), my_localtime(), my_gmtime()
11136 * By default traffic in UTC time values, using CRTL gmtime() or
11137 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11138 * Note: We need to use these functions even when the CRTL has working
11139 * UTC support, since they also handle C<use vmsish qw(times);>
11141 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
11142 * Modified by Charles Bailey <bailey@newman.upenn.edu>
11145 /*{{{time_t my_time(time_t *timep)*/
11146 time_t Perl_my_time(pTHX_ time_t *timep)
11151 if (gmtime_emulation_type == 0) {
11153 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11154 /* results of calls to gmtime() and localtime() */
11155 /* for same &base */
11157 gmtime_emulation_type++;
11158 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11159 char off[LNM$C_NAMLENGTH+1];;
11161 gmtime_emulation_type++;
11162 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11163 gmtime_emulation_type++;
11164 utc_offset_secs = 0;
11165 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11167 else { utc_offset_secs = atol(off); }
11169 else { /* We've got a working gmtime() */
11170 struct tm gmt, local;
11173 tm_p = localtime(&base);
11175 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11176 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11177 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11178 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11183 # ifdef VMSISH_TIME
11184 # ifdef RTL_USES_UTC
11185 if (VMSISH_TIME) when = _toloc(when);
11187 if (!VMSISH_TIME) when = _toutc(when);
11190 if (timep != NULL) *timep = when;
11193 } /* end of my_time() */
11197 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11199 Perl_my_gmtime(pTHX_ const time_t *timep)
11205 if (timep == NULL) {
11206 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11209 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11212 # ifdef VMSISH_TIME
11213 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11215 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
11216 return gmtime(&when);
11218 /* CRTL localtime() wants local time as input, so does no tz correction */
11219 rsltmp = localtime(&when);
11220 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
11223 } /* end of my_gmtime() */
11227 /*{{{struct tm *my_localtime(const time_t *timep)*/
11229 Perl_my_localtime(pTHX_ const time_t *timep)
11231 time_t when, whenutc;
11235 if (timep == NULL) {
11236 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11239 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11240 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11243 # ifdef RTL_USES_UTC
11244 # ifdef VMSISH_TIME
11245 if (VMSISH_TIME) when = _toutc(when);
11247 /* CRTL localtime() wants UTC as input, does tz correction itself */
11248 return localtime(&when);
11250 # else /* !RTL_USES_UTC */
11252 # ifdef VMSISH_TIME
11253 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
11254 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
11257 #ifndef RTL_USES_UTC
11258 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
11259 when = whenutc - offset; /* pseudolocal time*/
11262 /* CRTL localtime() wants local time as input, so does no tz correction */
11263 rsltmp = localtime(&when);
11264 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11268 } /* end of my_localtime() */
11271 /* Reset definitions for later calls */
11272 #define gmtime(t) my_gmtime(t)
11273 #define localtime(t) my_localtime(t)
11274 #define time(t) my_time(t)
11277 /* my_utime - update modification/access time of a file
11279 * VMS 7.3 and later implementation
11280 * Only the UTC translation is home-grown. The rest is handled by the
11281 * CRTL utime(), which will take into account the relevant feature
11282 * logicals and ODS-5 volume characteristics for true access times.
11284 * pre VMS 7.3 implementation:
11285 * The calling sequence is identical to POSIX utime(), but under
11286 * VMS with ODS-2, only the modification time is changed; ODS-2 does
11287 * not maintain access times. Restrictions differ from the POSIX
11288 * definition in that the time can be changed as long as the
11289 * caller has permission to execute the necessary IO$_MODIFY $QIO;
11290 * no separate checks are made to insure that the caller is the
11291 * owner of the file or has special privs enabled.
11292 * Code here is based on Joe Meadows' FILE utility.
11296 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11297 * to VMS epoch (01-JAN-1858 00:00:00.00)
11298 * in 100 ns intervals.
11300 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11302 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11303 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11305 #if __CRTL_VER >= 70300000
11306 struct utimbuf utc_utimes, *utc_utimesp;
11308 if (utimes != NULL) {
11309 utc_utimes.actime = utimes->actime;
11310 utc_utimes.modtime = utimes->modtime;
11311 # ifdef VMSISH_TIME
11312 /* If input was local; convert to UTC for sys svc */
11314 utc_utimes.actime = _toutc(utimes->actime);
11315 utc_utimes.modtime = _toutc(utimes->modtime);
11318 utc_utimesp = &utc_utimes;
11321 utc_utimesp = NULL;
11324 return utime(file, utc_utimesp);
11326 #else /* __CRTL_VER < 70300000 */
11330 long int bintime[2], len = 2, lowbit, unixtime,
11331 secscale = 10000000; /* seconds --> 100 ns intervals */
11332 unsigned long int chan, iosb[2], retsts;
11333 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11334 struct FAB myfab = cc$rms_fab;
11335 struct NAM mynam = cc$rms_nam;
11336 #if defined (__DECC) && defined (__VAX)
11337 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11338 * at least through VMS V6.1, which causes a type-conversion warning.
11340 # pragma message save
11341 # pragma message disable cvtdiftypes
11343 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11344 struct fibdef myfib;
11345 #if defined (__DECC) && defined (__VAX)
11346 /* This should be right after the declaration of myatr, but due
11347 * to a bug in VAX DEC C, this takes effect a statement early.
11349 # pragma message restore
11351 /* cast ok for read only parameter */
11352 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11353 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11354 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11356 if (file == NULL || *file == '\0') {
11357 SETERRNO(ENOENT, LIB$_INVARG);
11361 /* Convert to VMS format ensuring that it will fit in 255 characters */
11362 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11363 SETERRNO(ENOENT, LIB$_INVARG);
11366 if (utimes != NULL) {
11367 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
11368 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11369 * Since time_t is unsigned long int, and lib$emul takes a signed long int
11370 * as input, we force the sign bit to be clear by shifting unixtime right
11371 * one bit, then multiplying by an extra factor of 2 in lib$emul().
11373 lowbit = (utimes->modtime & 1) ? secscale : 0;
11374 unixtime = (long int) utimes->modtime;
11375 # ifdef VMSISH_TIME
11376 /* If input was UTC; convert to local for sys svc */
11377 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11379 unixtime >>= 1; secscale <<= 1;
11380 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11381 if (!(retsts & 1)) {
11382 SETERRNO(EVMSERR, retsts);
11385 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11386 if (!(retsts & 1)) {
11387 SETERRNO(EVMSERR, retsts);
11392 /* Just get the current time in VMS format directly */
11393 retsts = sys$gettim(bintime);
11394 if (!(retsts & 1)) {
11395 SETERRNO(EVMSERR, retsts);
11400 myfab.fab$l_fna = vmsspec;
11401 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11402 myfab.fab$l_nam = &mynam;
11403 mynam.nam$l_esa = esa;
11404 mynam.nam$b_ess = (unsigned char) sizeof esa;
11405 mynam.nam$l_rsa = rsa;
11406 mynam.nam$b_rss = (unsigned char) sizeof rsa;
11407 if (decc_efs_case_preserve)
11408 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11410 /* Look for the file to be affected, letting RMS parse the file
11411 * specification for us as well. I have set errno using only
11412 * values documented in the utime() man page for VMS POSIX.
11414 retsts = sys$parse(&myfab,0,0);
11415 if (!(retsts & 1)) {
11416 set_vaxc_errno(retsts);
11417 if (retsts == RMS$_PRV) set_errno(EACCES);
11418 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11419 else set_errno(EVMSERR);
11422 retsts = sys$search(&myfab,0,0);
11423 if (!(retsts & 1)) {
11424 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11425 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11426 set_vaxc_errno(retsts);
11427 if (retsts == RMS$_PRV) set_errno(EACCES);
11428 else if (retsts == RMS$_FNF) set_errno(ENOENT);
11429 else set_errno(EVMSERR);
11433 devdsc.dsc$w_length = mynam.nam$b_dev;
11434 /* cast ok for read only parameter */
11435 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11437 retsts = sys$assign(&devdsc,&chan,0,0);
11438 if (!(retsts & 1)) {
11439 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11440 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11441 set_vaxc_errno(retsts);
11442 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
11443 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
11444 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
11445 else set_errno(EVMSERR);
11449 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11450 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11452 memset((void *) &myfib, 0, sizeof myfib);
11453 #if defined(__DECC) || defined(__DECCXX)
11454 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11455 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11456 /* This prevents the revision time of the file being reset to the current
11457 * time as a result of our IO$_MODIFY $QIO. */
11458 myfib.fib$l_acctl = FIB$M_NORECORD;
11460 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11461 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11462 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11464 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11465 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11466 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11467 _ckvmssts(sys$dassgn(chan));
11468 if (retsts & 1) retsts = iosb[0];
11469 if (!(retsts & 1)) {
11470 set_vaxc_errno(retsts);
11471 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11472 else set_errno(EVMSERR);
11478 #endif /* #if __CRTL_VER >= 70300000 */
11480 } /* end of my_utime() */
11484 * flex_stat, flex_lstat, flex_fstat
11485 * basic stat, but gets it right when asked to stat
11486 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11489 #ifndef _USE_STD_STAT
11490 /* encode_dev packs a VMS device name string into an integer to allow
11491 * simple comparisons. This can be used, for example, to check whether two
11492 * files are located on the same device, by comparing their encoded device
11493 * names. Even a string comparison would not do, because stat() reuses the
11494 * device name buffer for each call; so without encode_dev, it would be
11495 * necessary to save the buffer and use strcmp (this would mean a number of
11496 * changes to the standard Perl code, to say nothing of what a Perl script
11497 * would have to do.
11499 * The device lock id, if it exists, should be unique (unless perhaps compared
11500 * with lock ids transferred from other nodes). We have a lock id if the disk is
11501 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11502 * device names. Thus we use the lock id in preference, and only if that isn't
11503 * available, do we try to pack the device name into an integer (flagged by
11504 * the sign bit (LOCKID_MASK) being set).
11506 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11507 * name and its encoded form, but it seems very unlikely that we will find
11508 * two files on different disks that share the same encoded device names,
11509 * and even more remote that they will share the same file id (if the test
11510 * is to check for the same file).
11512 * A better method might be to use sys$device_scan on the first call, and to
11513 * search for the device, returning an index into the cached array.
11514 * The number returned would be more intelligible.
11515 * This is probably not worth it, and anyway would take quite a bit longer
11516 * on the first call.
11518 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
11519 static mydev_t encode_dev (pTHX_ const char *dev)
11522 unsigned long int f;
11527 if (!dev || !dev[0]) return 0;
11531 struct dsc$descriptor_s dev_desc;
11532 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11534 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11535 can try that first. */
11536 dev_desc.dsc$w_length = strlen (dev);
11537 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11538 dev_desc.dsc$b_class = DSC$K_CLASS_S;
11539 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
11540 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11541 if (!$VMS_STATUS_SUCCESS(status)) {
11543 case SS$_NOSUCHDEV:
11544 SETERRNO(ENODEV, status);
11550 if (lockid) return (lockid & ~LOCKID_MASK);
11554 /* Otherwise we try to encode the device name */
11558 for (q = dev + strlen(dev); q--; q >= dev) {
11563 else if (isalpha (toupper (*q)))
11564 c= toupper (*q) - 'A' + (char)10;
11566 continue; /* Skip '$'s */
11568 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11570 enc += f * (unsigned long int) c;
11572 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11574 } /* end of encode_dev() */
11575 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11576 device_no = encode_dev(aTHX_ devname)
11578 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11579 device_no = new_dev_no
11583 is_null_device(name)
11586 if (decc_bug_devnull != 0) {
11587 if (strncmp("/dev/null", name, 9) == 0)
11590 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11591 The underscore prefix, controller letter, and unit number are
11592 independently optional; for our purposes, the colon punctuation
11593 is not. The colon can be trailed by optional directory and/or
11594 filename, but two consecutive colons indicates a nodename rather
11595 than a device. [pr] */
11596 if (*name == '_') ++name;
11597 if (tolower(*name++) != 'n') return 0;
11598 if (tolower(*name++) != 'l') return 0;
11599 if (tolower(*name) == 'a') ++name;
11600 if (*name == '0') ++name;
11601 return (*name++ == ':') && (*name != ':');
11606 Perl_cando_by_name_int
11607 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11609 char usrname[L_cuserid];
11610 struct dsc$descriptor_s usrdsc =
11611 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11612 char *vmsname = NULL, *fileified = NULL;
11613 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11614 unsigned short int retlen, trnlnm_iter_count;
11615 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11616 union prvdef curprv;
11617 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11618 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11619 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11620 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11621 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11623 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11625 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11627 static int profile_context = -1;
11629 if (!fname || !*fname) return FALSE;
11631 /* Make sure we expand logical names, since sys$check_access doesn't */
11632 fileified = PerlMem_malloc(VMS_MAXRSS);
11633 if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11634 if (!strpbrk(fname,"/]>:")) {
11635 strcpy(fileified,fname);
11636 trnlnm_iter_count = 0;
11637 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11638 trnlnm_iter_count++;
11639 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11644 vmsname = PerlMem_malloc(VMS_MAXRSS);
11645 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11646 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11647 /* Don't know if already in VMS format, so make sure */
11648 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11649 PerlMem_free(fileified);
11650 PerlMem_free(vmsname);
11655 strcpy(vmsname,fname);
11658 /* sys$check_access needs a file spec, not a directory spec.
11659 * Don't use flex_stat here, as that depends on thread context
11660 * having been initialized, and we may get here during startup.
11663 retlen = namdsc.dsc$w_length = strlen(vmsname);
11664 if (vmsname[retlen-1] == ']'
11665 || vmsname[retlen-1] == '>'
11666 || vmsname[retlen-1] == ':'
11667 || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11669 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11670 PerlMem_free(fileified);
11671 PerlMem_free(vmsname);
11680 retlen = namdsc.dsc$w_length = strlen(fname);
11681 namdsc.dsc$a_pointer = (char *)fname;
11684 case S_IXUSR: case S_IXGRP: case S_IXOTH:
11685 access = ARM$M_EXECUTE;
11686 flags = CHP$M_READ;
11688 case S_IRUSR: case S_IRGRP: case S_IROTH:
11689 access = ARM$M_READ;
11690 flags = CHP$M_READ | CHP$M_USEREADALL;
11692 case S_IWUSR: case S_IWGRP: case S_IWOTH:
11693 access = ARM$M_WRITE;
11694 flags = CHP$M_READ | CHP$M_WRITE;
11696 case S_IDUSR: case S_IDGRP: case S_IDOTH:
11697 access = ARM$M_DELETE;
11698 flags = CHP$M_READ | CHP$M_WRITE;
11701 if (fileified != NULL)
11702 PerlMem_free(fileified);
11703 if (vmsname != NULL)
11704 PerlMem_free(vmsname);
11708 /* Before we call $check_access, create a user profile with the current
11709 * process privs since otherwise it just uses the default privs from the
11710 * UAF and might give false positives or negatives. This only works on
11711 * VMS versions v6.0 and later since that's when sys$create_user_profile
11712 * became available.
11715 /* get current process privs and username */
11716 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11717 _ckvmssts(iosb[0]);
11719 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11721 /* find out the space required for the profile */
11722 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11723 &usrprodsc.dsc$w_length,&profile_context));
11725 /* allocate space for the profile and get it filled in */
11726 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11727 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11728 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11729 &usrprodsc.dsc$w_length,&profile_context));
11731 /* use the profile to check access to the file; free profile & analyze results */
11732 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11733 PerlMem_free(usrprodsc.dsc$a_pointer);
11734 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11738 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11742 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
11743 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11744 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11745 set_vaxc_errno(retsts);
11746 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11747 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11748 else set_errno(ENOENT);
11749 if (fileified != NULL)
11750 PerlMem_free(fileified);
11751 if (vmsname != NULL)
11752 PerlMem_free(vmsname);
11755 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11756 if (fileified != NULL)
11757 PerlMem_free(fileified);
11758 if (vmsname != NULL)
11759 PerlMem_free(vmsname);
11764 if (fileified != NULL)
11765 PerlMem_free(fileified);
11766 if (vmsname != NULL)
11767 PerlMem_free(vmsname);
11768 return FALSE; /* Should never get here */
11772 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
11773 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11774 * subset of the applicable information.
11777 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11779 return cando_by_name_int
11780 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11781 } /* end of cando() */
11785 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11787 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11789 return cando_by_name_int(bit, effective, fname, 0);
11791 } /* end of cando_by_name() */
11795 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11797 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11799 if (!fstat(fd,(stat_t *) statbufp)) {
11801 char *vms_filename;
11802 vms_filename = PerlMem_malloc(VMS_MAXRSS);
11803 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11805 /* Save name for cando by name in VMS format */
11806 cptr = getname(fd, vms_filename, 1);
11808 /* This should not happen, but just in case */
11809 if (cptr == NULL) {
11810 statbufp->st_devnam[0] = 0;
11813 /* Make sure that the saved name fits in 255 characters */
11814 cptr = do_rmsexpand
11816 statbufp->st_devnam,
11819 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11823 statbufp->st_devnam[0] = 0;
11825 PerlMem_free(vms_filename);
11827 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11829 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11831 # ifdef RTL_USES_UTC
11832 # ifdef VMSISH_TIME
11834 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11835 statbufp->st_atime = _toloc(statbufp->st_atime);
11836 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11840 # ifdef VMSISH_TIME
11841 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11845 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11846 statbufp->st_atime = _toutc(statbufp->st_atime);
11847 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11854 } /* end of flex_fstat() */
11857 #if !defined(__VAX) && __CRTL_VER >= 80200000
11865 #define lstat(_x, _y) stat(_x, _y)
11868 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11871 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11873 char fileified[VMS_MAXRSS];
11874 char temp_fspec[VMS_MAXRSS];
11877 int saved_errno, saved_vaxc_errno;
11879 if (!fspec) return retval;
11880 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11881 strcpy(temp_fspec, fspec);
11883 if (decc_bug_devnull != 0) {
11884 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11885 memset(statbufp,0,sizeof *statbufp);
11886 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11887 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11888 statbufp->st_uid = 0x00010001;
11889 statbufp->st_gid = 0x0001;
11890 time((time_t *)&statbufp->st_mtime);
11891 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11896 /* Try for a directory name first. If fspec contains a filename without
11897 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11898 * and sea:[wine.dark]water. exist, we prefer the directory here.
11899 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11900 * not sea:[wine.dark]., if the latter exists. If the intended target is
11901 * the file with null type, specify this by calling flex_stat() with
11902 * a '.' at the end of fspec.
11904 * If we are in Posix filespec mode, accept the filename as is.
11908 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11909 /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11910 * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11912 if (!decc_efs_charset)
11913 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11916 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11917 if (decc_posix_compliant_pathnames == 0) {
11919 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11920 if (lstat_flag == 0)
11921 retval = stat(fileified,(stat_t *) statbufp);
11923 retval = lstat(fileified,(stat_t *) statbufp);
11924 save_spec = fileified;
11927 if (lstat_flag == 0)
11928 retval = stat(temp_fspec,(stat_t *) statbufp);
11930 retval = lstat(temp_fspec,(stat_t *) statbufp);
11931 save_spec = temp_fspec;
11934 * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11935 * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11936 * and lstat was working correctly for the same file.
11937 * The only syntax that was working for stat was "foo:[bar]t.dir".
11939 * Other directories with the same syntax worked fine.
11940 * So work around the problem when it shows up here.
11943 int save_errno = errno;
11944 if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
11945 if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
11946 retval = stat(fileified, (stat_t *) statbufp);
11947 save_spec = fileified;
11950 /* Restore the errno value if third stat does not succeed */
11952 errno = save_errno;
11954 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11956 if (lstat_flag == 0)
11957 retval = stat(temp_fspec,(stat_t *) statbufp);
11959 retval = lstat(temp_fspec,(stat_t *) statbufp);
11960 save_spec = temp_fspec;
11964 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11965 /* As you were... */
11966 if (!decc_efs_charset)
11967 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11972 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
11974 /* If this is an lstat, do not follow the link */
11976 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
11978 cptr = do_rmsexpand
11979 (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
11981 statbufp->st_devnam[0] = 0;
11983 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11985 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11986 # ifdef RTL_USES_UTC
11987 # ifdef VMSISH_TIME
11989 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11990 statbufp->st_atime = _toloc(statbufp->st_atime);
11991 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11995 # ifdef VMSISH_TIME
11996 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12000 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12001 statbufp->st_atime = _toutc(statbufp->st_atime);
12002 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12006 /* If we were successful, leave errno where we found it */
12007 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
12010 } /* end of flex_stat_int() */
12013 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12015 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12017 return flex_stat_int(fspec, statbufp, 0);
12021 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12023 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12025 return flex_stat_int(fspec, statbufp, 1);
12030 /*{{{char *my_getlogin()*/
12031 /* VMS cuserid == Unix getlogin, except calling sequence */
12035 static char user[L_cuserid];
12036 return cuserid(user);
12041 /* rmscopy - copy a file using VMS RMS routines
12043 * Copies contents and attributes of spec_in to spec_out, except owner
12044 * and protection information. Name and type of spec_in are used as
12045 * defaults for spec_out. The third parameter specifies whether rmscopy()
12046 * should try to propagate timestamps from the input file to the output file.
12047 * If it is less than 0, no timestamps are preserved. If it is 0, then
12048 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12049 * propagated to the output file at creation iff the output file specification
12050 * did not contain an explicit name or type, and the revision date is always
12051 * updated at the end of the copy operation. If it is greater than 0, then
12052 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12053 * other than the revision date should be propagated, and bit 1 indicates
12054 * that the revision date should be propagated.
12056 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12058 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12059 * Incorporates, with permission, some code from EZCOPY by Tim Adye
12060 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12061 * as part of the Perl standard distribution under the terms of the
12062 * GNU General Public License or the Perl Artistic License. Copies
12063 * of each may be found in the Perl standard distribution.
12065 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12067 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12069 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12070 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12071 unsigned long int i, sts, sts2;
12073 struct FAB fab_in, fab_out;
12074 struct RAB rab_in, rab_out;
12075 rms_setup_nam(nam);
12076 rms_setup_nam(nam_out);
12077 struct XABDAT xabdat;
12078 struct XABFHC xabfhc;
12079 struct XABRDT xabrdt;
12080 struct XABSUM xabsum;
12082 vmsin = PerlMem_malloc(VMS_MAXRSS);
12083 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
12084 vmsout = PerlMem_malloc(VMS_MAXRSS);
12085 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
12086 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
12087 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
12088 PerlMem_free(vmsin);
12089 PerlMem_free(vmsout);
12090 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12094 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
12095 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
12097 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12098 esal = PerlMem_malloc(VMS_MAXRSS);
12099 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
12101 fab_in = cc$rms_fab;
12102 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12103 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12104 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12105 fab_in.fab$l_fop = FAB$M_SQO;
12106 rms_bind_fab_nam(fab_in, nam);
12107 fab_in.fab$l_xab = (void *) &xabdat;
12109 rsa = PerlMem_malloc(NAML$C_MAXRSS);
12110 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
12112 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12113 rsal = PerlMem_malloc(VMS_MAXRSS);
12114 if (rsal == NULL) _ckvmssts(SS$_INSFMEM);
12116 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12117 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12118 rms_nam_esl(nam) = 0;
12119 rms_nam_rsl(nam) = 0;
12120 rms_nam_esll(nam) = 0;
12121 rms_nam_rsll(nam) = 0;
12122 #ifdef NAM$M_NO_SHORT_UPCASE
12123 if (decc_efs_case_preserve)
12124 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12127 xabdat = cc$rms_xabdat; /* To get creation date */
12128 xabdat.xab$l_nxt = (void *) &xabfhc;
12130 xabfhc = cc$rms_xabfhc; /* To get record length */
12131 xabfhc.xab$l_nxt = (void *) &xabsum;
12133 xabsum = cc$rms_xabsum; /* To get key and area information */
12135 if (!((sts = sys$open(&fab_in)) & 1)) {
12136 PerlMem_free(vmsin);
12137 PerlMem_free(vmsout);
12140 PerlMem_free(esal);
12143 PerlMem_free(rsal);
12144 set_vaxc_errno(sts);
12146 case RMS$_FNF: case RMS$_DNF:
12147 set_errno(ENOENT); break;
12149 set_errno(ENOTDIR); break;
12151 set_errno(ENODEV); break;
12153 set_errno(EINVAL); break;
12155 set_errno(EACCES); break;
12157 set_errno(EVMSERR);
12164 fab_out.fab$w_ifi = 0;
12165 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12166 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12167 fab_out.fab$l_fop = FAB$M_SQO;
12168 rms_bind_fab_nam(fab_out, nam_out);
12169 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12170 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12171 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12172 esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12173 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
12174 rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12175 if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
12178 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12179 esal_out = PerlMem_malloc(VMS_MAXRSS);
12180 if (esal_out == NULL) _ckvmssts(SS$_INSFMEM);
12181 rsal_out = PerlMem_malloc(VMS_MAXRSS);
12182 if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
12184 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12185 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12187 if (preserve_dates == 0) { /* Act like DCL COPY */
12188 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12189 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
12190 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12191 PerlMem_free(vmsin);
12192 PerlMem_free(vmsout);
12195 PerlMem_free(esal);
12198 PerlMem_free(rsal);
12199 PerlMem_free(esa_out);
12200 if (esal_out != NULL)
12201 PerlMem_free(esal_out);
12202 PerlMem_free(rsa_out);
12203 if (rsal_out != NULL)
12204 PerlMem_free(rsal_out);
12205 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12206 set_vaxc_errno(sts);
12209 fab_out.fab$l_xab = (void *) &xabdat;
12210 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12211 preserve_dates = 1;
12213 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12214 preserve_dates =0; /* bitmask from this point forward */
12216 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12217 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12218 PerlMem_free(vmsin);
12219 PerlMem_free(vmsout);
12222 PerlMem_free(esal);
12225 PerlMem_free(rsal);
12226 PerlMem_free(esa_out);
12227 if (esal_out != NULL)
12228 PerlMem_free(esal_out);
12229 PerlMem_free(rsa_out);
12230 if (rsal_out != NULL)
12231 PerlMem_free(rsal_out);
12232 set_vaxc_errno(sts);
12235 set_errno(ENOENT); break;
12237 set_errno(ENOTDIR); break;
12239 set_errno(ENODEV); break;
12241 set_errno(EINVAL); break;
12243 set_errno(EACCES); break;
12245 set_errno(EVMSERR);
12249 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12250 if (preserve_dates & 2) {
12251 /* sys$close() will process xabrdt, not xabdat */
12252 xabrdt = cc$rms_xabrdt;
12254 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12256 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12257 * is unsigned long[2], while DECC & VAXC use a struct */
12258 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12260 fab_out.fab$l_xab = (void *) &xabrdt;
12263 ubf = PerlMem_malloc(32256);
12264 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12265 rab_in = cc$rms_rab;
12266 rab_in.rab$l_fab = &fab_in;
12267 rab_in.rab$l_rop = RAB$M_BIO;
12268 rab_in.rab$l_ubf = ubf;
12269 rab_in.rab$w_usz = 32256;
12270 if (!((sts = sys$connect(&rab_in)) & 1)) {
12271 sys$close(&fab_in); sys$close(&fab_out);
12272 PerlMem_free(vmsin);
12273 PerlMem_free(vmsout);
12277 PerlMem_free(esal);
12280 PerlMem_free(rsal);
12281 PerlMem_free(esa_out);
12282 if (esal_out != NULL)
12283 PerlMem_free(esal_out);
12284 PerlMem_free(rsa_out);
12285 if (rsal_out != NULL)
12286 PerlMem_free(rsal_out);
12287 set_errno(EVMSERR); set_vaxc_errno(sts);
12291 rab_out = cc$rms_rab;
12292 rab_out.rab$l_fab = &fab_out;
12293 rab_out.rab$l_rbf = ubf;
12294 if (!((sts = sys$connect(&rab_out)) & 1)) {
12295 sys$close(&fab_in); sys$close(&fab_out);
12296 PerlMem_free(vmsin);
12297 PerlMem_free(vmsout);
12301 PerlMem_free(esal);
12304 PerlMem_free(rsal);
12305 PerlMem_free(esa_out);
12306 if (esal_out != NULL)
12307 PerlMem_free(esal_out);
12308 PerlMem_free(rsa_out);
12309 if (rsal_out != NULL)
12310 PerlMem_free(rsal_out);
12311 set_errno(EVMSERR); set_vaxc_errno(sts);
12315 while ((sts = sys$read(&rab_in))) { /* always true */
12316 if (sts == RMS$_EOF) break;
12317 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12318 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12319 sys$close(&fab_in); sys$close(&fab_out);
12320 PerlMem_free(vmsin);
12321 PerlMem_free(vmsout);
12325 PerlMem_free(esal);
12328 PerlMem_free(rsal);
12329 PerlMem_free(esa_out);
12330 if (esal_out != NULL)
12331 PerlMem_free(esal_out);
12332 PerlMem_free(rsa_out);
12333 if (rsal_out != NULL)
12334 PerlMem_free(rsal_out);
12335 set_errno(EVMSERR); set_vaxc_errno(sts);
12341 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12342 sys$close(&fab_in); sys$close(&fab_out);
12343 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12345 PerlMem_free(vmsin);
12346 PerlMem_free(vmsout);
12350 PerlMem_free(esal);
12353 PerlMem_free(rsal);
12354 PerlMem_free(esa_out);
12355 if (esal_out != NULL)
12356 PerlMem_free(esal_out);
12357 PerlMem_free(rsa_out);
12358 if (rsal_out != NULL)
12359 PerlMem_free(rsal_out);
12362 set_errno(EVMSERR); set_vaxc_errno(sts);
12368 } /* end of rmscopy() */
12372 /*** The following glue provides 'hooks' to make some of the routines
12373 * from this file available from Perl. These routines are sufficiently
12374 * basic, and are required sufficiently early in the build process,
12375 * that's it's nice to have them available to miniperl as well as the
12376 * full Perl, so they're set up here instead of in an extension. The
12377 * Perl code which handles importation of these names into a given
12378 * package lives in [.VMS]Filespec.pm in @INC.
12382 rmsexpand_fromperl(pTHX_ CV *cv)
12385 char *fspec, *defspec = NULL, *rslt;
12387 int fs_utf8, dfs_utf8;
12391 if (!items || items > 2)
12392 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12393 fspec = SvPV(ST(0),n_a);
12394 fs_utf8 = SvUTF8(ST(0));
12395 if (!fspec || !*fspec) XSRETURN_UNDEF;
12397 defspec = SvPV(ST(1),n_a);
12398 dfs_utf8 = SvUTF8(ST(1));
12400 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12401 ST(0) = sv_newmortal();
12402 if (rslt != NULL) {
12403 sv_usepvn(ST(0),rslt,strlen(rslt));
12412 vmsify_fromperl(pTHX_ CV *cv)
12419 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12420 utf8_fl = SvUTF8(ST(0));
12421 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12422 ST(0) = sv_newmortal();
12423 if (vmsified != NULL) {
12424 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12433 unixify_fromperl(pTHX_ CV *cv)
12440 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12441 utf8_fl = SvUTF8(ST(0));
12442 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12443 ST(0) = sv_newmortal();
12444 if (unixified != NULL) {
12445 sv_usepvn(ST(0),unixified,strlen(unixified));
12454 fileify_fromperl(pTHX_ CV *cv)
12461 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12462 utf8_fl = SvUTF8(ST(0));
12463 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12464 ST(0) = sv_newmortal();
12465 if (fileified != NULL) {
12466 sv_usepvn(ST(0),fileified,strlen(fileified));
12475 pathify_fromperl(pTHX_ CV *cv)
12482 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12483 utf8_fl = SvUTF8(ST(0));
12484 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12485 ST(0) = sv_newmortal();
12486 if (pathified != NULL) {
12487 sv_usepvn(ST(0),pathified,strlen(pathified));
12496 vmspath_fromperl(pTHX_ CV *cv)
12503 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12504 utf8_fl = SvUTF8(ST(0));
12505 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12506 ST(0) = sv_newmortal();
12507 if (vmspath != NULL) {
12508 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12517 unixpath_fromperl(pTHX_ CV *cv)
12524 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12525 utf8_fl = SvUTF8(ST(0));
12526 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12527 ST(0) = sv_newmortal();
12528 if (unixpath != NULL) {
12529 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12538 candelete_fromperl(pTHX_ CV *cv)
12546 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12548 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12549 Newx(fspec, VMS_MAXRSS, char);
12550 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12551 if (SvTYPE(mysv) == SVt_PVGV) {
12552 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12553 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12561 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12562 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12569 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12575 rmscopy_fromperl(pTHX_ CV *cv)
12578 char *inspec, *outspec, *inp, *outp;
12580 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12581 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12582 unsigned long int sts;
12587 if (items < 2 || items > 3)
12588 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12590 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12591 Newx(inspec, VMS_MAXRSS, char);
12592 if (SvTYPE(mysv) == SVt_PVGV) {
12593 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12594 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12602 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12603 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12609 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12610 Newx(outspec, VMS_MAXRSS, char);
12611 if (SvTYPE(mysv) == SVt_PVGV) {
12612 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12613 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12622 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12623 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12630 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12632 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12638 /* The mod2fname is limited to shorter filenames by design, so it should
12639 * not be modified to support longer EFS pathnames
12642 mod2fname(pTHX_ CV *cv)
12645 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12646 workbuff[NAM$C_MAXRSS*1 + 1];
12647 int total_namelen = 3, counter, num_entries;
12648 /* ODS-5 ups this, but we want to be consistent, so... */
12649 int max_name_len = 39;
12650 AV *in_array = (AV *)SvRV(ST(0));
12652 num_entries = av_len(in_array);
12654 /* All the names start with PL_. */
12655 strcpy(ultimate_name, "PL_");
12657 /* Clean up our working buffer */
12658 Zero(work_name, sizeof(work_name), char);
12660 /* Run through the entries and build up a working name */
12661 for(counter = 0; counter <= num_entries; counter++) {
12662 /* If it's not the first name then tack on a __ */
12664 strcat(work_name, "__");
12666 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
12670 /* Check to see if we actually have to bother...*/
12671 if (strlen(work_name) + 3 <= max_name_len) {
12672 strcat(ultimate_name, work_name);
12674 /* It's too darned big, so we need to go strip. We use the same */
12675 /* algorithm as xsubpp does. First, strip out doubled __ */
12676 char *source, *dest, last;
12679 for (source = work_name; *source; source++) {
12680 if (last == *source && last == '_') {
12686 /* Go put it back */
12687 strcpy(work_name, workbuff);
12688 /* Is it still too big? */
12689 if (strlen(work_name) + 3 > max_name_len) {
12690 /* Strip duplicate letters */
12693 for (source = work_name; *source; source++) {
12694 if (last == toupper(*source)) {
12698 last = toupper(*source);
12700 strcpy(work_name, workbuff);
12703 /* Is it *still* too big? */
12704 if (strlen(work_name) + 3 > max_name_len) {
12705 /* Too bad, we truncate */
12706 work_name[max_name_len - 2] = 0;
12708 strcat(ultimate_name, work_name);
12711 /* Okay, return it */
12712 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12717 hushexit_fromperl(pTHX_ CV *cv)
12722 VMSISH_HUSHED = SvTRUE(ST(0));
12724 ST(0) = boolSV(VMSISH_HUSHED);
12730 Perl_vms_start_glob
12731 (pTHX_ SV *tmpglob,
12735 struct vs_str_st *rslt;
12739 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12742 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12743 struct dsc$descriptor_vs rsdsc;
12744 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12745 unsigned long hasver = 0, isunix = 0;
12746 unsigned long int lff_flags = 0;
12749 #ifdef VMS_LONGNAME_SUPPORT
12750 lff_flags = LIB$M_FIL_LONG_NAMES;
12752 /* The Newx macro will not allow me to assign a smaller array
12753 * to the rslt pointer, so we will assign it to the begin char pointer
12754 * and then copy the value into the rslt pointer.
12756 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12757 rslt = (struct vs_str_st *)begin;
12759 rstr = &rslt->str[0];
12760 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12761 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12762 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12763 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12765 Newx(vmsspec, VMS_MAXRSS, char);
12767 /* We could find out if there's an explicit dev/dir or version
12768 by peeking into lib$find_file's internal context at
12769 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12770 but that's unsupported, so I don't want to do it now and
12771 have it bite someone in the future. */
12772 /* Fix-me: vms_split_path() is the only way to do this, the
12773 existing method will fail with many legal EFS or UNIX specifications
12776 cp = SvPV(tmpglob,i);
12779 if (cp[i] == ';') hasver = 1;
12780 if (cp[i] == '.') {
12781 if (sts) hasver = 1;
12784 if (cp[i] == '/') {
12785 hasdir = isunix = 1;
12788 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12793 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12797 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12798 if (!stat_sts && S_ISDIR(st.st_mode)) {
12799 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12800 ok = (wilddsc.dsc$a_pointer != NULL);
12801 /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12805 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12806 ok = (wilddsc.dsc$a_pointer != NULL);
12809 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12811 /* If not extended character set, replace ? with % */
12812 /* With extended character set, ? is a wildcard single character */
12813 if (!decc_efs_case_preserve) {
12814 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12815 if (*cp == '?') *cp = '%';
12818 while (ok && $VMS_STATUS_SUCCESS(sts)) {
12819 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12820 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12822 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12823 &dfltdsc,NULL,&rms_sts,&lff_flags);
12824 if (!$VMS_STATUS_SUCCESS(sts))
12829 /* with varying string, 1st word of buffer contains result length */
12830 rstr[rslt->length] = '\0';
12832 /* Find where all the components are */
12833 v_sts = vms_split_path
12848 /* If no version on input, truncate the version on output */
12849 if (!hasver && (vs_len > 0)) {
12853 /* No version & a null extension on UNIX handling */
12854 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12860 if (!decc_efs_case_preserve) {
12861 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12865 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12869 /* Start with the name */
12872 strcat(begin,"\n");
12873 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12875 if (cxt) (void)lib$find_file_end(&cxt);
12878 /* Be POSIXish: return the input pattern when no matches */
12879 begin = SvPVX(tmpglob);
12880 strcat(begin,"\n");
12881 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12884 if (ok && sts != RMS$_NMF &&
12885 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12888 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12890 PerlIO_close(tmpfp);
12894 PerlIO_rewind(tmpfp);
12895 IoTYPE(io) = IoTYPE_RDONLY;
12896 IoIFP(io) = fp = tmpfp;
12897 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
12908 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12912 vms_realpath_fromperl(pTHX_ CV *cv)
12915 char *fspec, *rslt_spec, *rslt;
12918 if (!items || items != 1)
12919 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12921 fspec = SvPV(ST(0),n_a);
12922 if (!fspec || !*fspec) XSRETURN_UNDEF;
12924 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12925 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12927 ST(0) = sv_newmortal();
12929 sv_usepvn(ST(0),rslt,strlen(rslt));
12931 Safefree(rslt_spec);
12936 * A thin wrapper around decc$symlink to make sure we follow the
12937 * standard and do not create a symlink with a zero-length name.
12939 /*{{{ int my_symlink(const char *path1, const char *path2)*/
12940 int my_symlink(const char *path1, const char *path2) {
12941 if (!path2 || !*path2) {
12942 SETERRNO(ENOENT, SS$_NOSUCHFILE);
12945 return symlink(path1, path2);
12949 #endif /* HAS_SYMLINK */
12951 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12952 int do_vms_case_tolerant(void);
12955 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12958 ST(0) = boolSV(do_vms_case_tolerant());
12964 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12965 struct interp_intern *dst)
12967 memcpy(dst,src,sizeof(struct interp_intern));
12971 Perl_sys_intern_clear(pTHX)
12976 Perl_sys_intern_init(pTHX)
12978 unsigned int ix = RAND_MAX;
12983 /* fix me later to track running under GNV */
12984 /* this allows some limited testing */
12985 MY_POSIX_EXIT = decc_filename_unix_report;
12988 MY_INV_RAND_MAX = 1./x;
12992 init_os_extras(void)
12995 char* file = __FILE__;
12996 if (decc_disable_to_vms_logname_translation) {
12997 no_translate_barewords = TRUE;
12999 no_translate_barewords = FALSE;
13002 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13003 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13004 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13005 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13006 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13007 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13008 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13009 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13010 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13011 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13012 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13014 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
13016 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13017 newXSproto("VMS::Filepec::vms_case_tolerant",
13018 vms_case_tolerant_fromperl, file, "$");
13021 store_pipelocs(aTHX); /* will redo any earlier attempts */
13028 #if __CRTL_VER == 80200000
13029 /* This missed getting in to the DECC SDK for 8.2 */
13030 char *realpath(const char *file_name, char * resolved_name, ...);
13033 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13034 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13035 * The perl fallback routine to provide realpath() is not as efficient
13039 /* Hack, use old stat() as fastest way of getting ino_t and device */
13040 int decc$stat(const char *name, void * statbuf);
13043 /* Realpath is fragile. In 8.3 it does not work if the feature
13044 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13045 * links are implemented in RMS, not the CRTL. It also can fail if the
13046 * user does not have read/execute access to some of the directories.
13047 * So in order for Do What I Mean mode to work, if realpath() fails,
13048 * fall back to looking up the filename by the device name and FID.
13051 int vms_fid_to_name(char * outname, int outlen, const char * name)
13055 __ino16_t st_ino[3];
13056 unsigned short padw;
13057 unsigned long padl[30]; /* plenty of room */
13060 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13061 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13063 sts = decc$stat(name, &statbuf);
13066 dvidsc.dsc$a_pointer=statbuf.st_dev;
13067 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13069 specdsc.dsc$a_pointer = outname;
13070 specdsc.dsc$w_length = outlen-1;
13072 sts = lib$fid_to_name
13073 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13074 if ($VMS_STATUS_SUCCESS(sts)) {
13075 outname[specdsc.dsc$w_length] = 0;
13085 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13088 char * rslt = NULL;
13090 if (decc_posix_compliant_pathnames)
13091 rslt = realpath(filespec, outbuf);
13093 if (rslt == NULL) {
13095 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13096 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13099 /* Fall back to fid_to_name */
13101 Newx(vms_spec, VMS_MAXRSS + 1, char);
13103 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13107 /* Now need to trim the version off */
13108 sts = vms_split_path
13127 /* Trim off the version */
13128 file_len = v_len + r_len + d_len + n_len + e_len;
13129 vms_spec[file_len] = 0;
13131 /* The result is expected to be in UNIX format */
13132 rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13136 Safefree(vms_spec);
13142 /* External entry points */
13143 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13144 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13146 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13151 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13152 /* case_tolerant */
13154 /*{{{int do_vms_case_tolerant(void)*/
13155 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13156 * controlled by a process setting.
13158 int do_vms_case_tolerant(void)
13160 return vms_process_case_tolerant;
13163 /* External entry points */
13164 int Perl_vms_case_tolerant(void)
13165 { return do_vms_case_tolerant(); }
13167 int Perl_vms_case_tolerant(void)
13168 { return vms_process_case_tolerant; }
13172 /* Start of DECC RTL Feature handling */
13174 static int sys_trnlnm
13175 (const char * logname,
13179 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13180 const unsigned long attr = LNM$M_CASE_BLIND;
13181 struct dsc$descriptor_s name_dsc;
13183 unsigned short result;
13184 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13187 name_dsc.dsc$w_length = strlen(logname);
13188 name_dsc.dsc$a_pointer = (char *)logname;
13189 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13190 name_dsc.dsc$b_class = DSC$K_CLASS_S;
13192 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13194 if ($VMS_STATUS_SUCCESS(status)) {
13196 /* Null terminate and return the string */
13197 /*--------------------------------------*/
13204 static int sys_crelnm
13205 (const char * logname,
13206 const char * value)
13209 const char * proc_table = "LNM$PROCESS_TABLE";
13210 struct dsc$descriptor_s proc_table_dsc;
13211 struct dsc$descriptor_s logname_dsc;
13212 struct itmlst_3 item_list[2];
13214 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13215 proc_table_dsc.dsc$w_length = strlen(proc_table);
13216 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13217 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13219 logname_dsc.dsc$a_pointer = (char *) logname;
13220 logname_dsc.dsc$w_length = strlen(logname);
13221 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13222 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13224 item_list[0].buflen = strlen(value);
13225 item_list[0].itmcode = LNM$_STRING;
13226 item_list[0].bufadr = (char *)value;
13227 item_list[0].retlen = NULL;
13229 item_list[1].buflen = 0;
13230 item_list[1].itmcode = 0;
13232 ret_val = sys$crelnm
13234 (const struct dsc$descriptor_s *)&proc_table_dsc,
13235 (const struct dsc$descriptor_s *)&logname_dsc,
13237 (const struct item_list_3 *) item_list);
13242 /* C RTL Feature settings */
13244 static int set_features
13245 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
13246 int (* cli_routine)(void), /* Not documented */
13247 void *image_info) /* Not documented */
13254 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13255 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13256 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13257 unsigned long case_perm;
13258 unsigned long case_image;
13261 /* Allow an exception to bring Perl into the VMS debugger */
13262 vms_debug_on_exception = 0;
13263 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13264 if ($VMS_STATUS_SUCCESS(status)) {
13265 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13266 vms_debug_on_exception = 1;
13268 vms_debug_on_exception = 0;
13271 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13272 vms_vtf7_filenames = 0;
13273 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13274 if ($VMS_STATUS_SUCCESS(status)) {
13275 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13276 vms_vtf7_filenames = 1;
13278 vms_vtf7_filenames = 0;
13282 /* unlink all versions on unlink() or rename() */
13283 vms_unlink_all_versions = 0;
13284 status = sys_trnlnm
13285 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13286 if ($VMS_STATUS_SUCCESS(status)) {
13287 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13288 vms_unlink_all_versions = 1;
13290 vms_unlink_all_versions = 0;
13293 /* Dectect running under GNV Bash or other UNIX like shell */
13294 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13295 gnv_unix_shell = 0;
13296 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13297 if ($VMS_STATUS_SUCCESS(status)) {
13298 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13299 gnv_unix_shell = 1;
13300 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13301 set_feature_default("DECC$EFS_CHARSET", 1);
13302 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13303 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13304 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13305 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13306 vms_unlink_all_versions = 1;
13309 gnv_unix_shell = 0;
13313 /* hacks to see if known bugs are still present for testing */
13315 /* Readdir is returning filenames in VMS syntax always */
13316 decc_bug_readdir_efs1 = 1;
13317 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13318 if ($VMS_STATUS_SUCCESS(status)) {
13319 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13320 decc_bug_readdir_efs1 = 1;
13322 decc_bug_readdir_efs1 = 0;
13325 /* PCP mode requires creating /dev/null special device file */
13326 decc_bug_devnull = 0;
13327 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13328 if ($VMS_STATUS_SUCCESS(status)) {
13329 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13330 decc_bug_devnull = 1;
13332 decc_bug_devnull = 0;
13335 /* fgetname returning a VMS name in UNIX mode */
13336 decc_bug_fgetname = 1;
13337 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13338 if ($VMS_STATUS_SUCCESS(status)) {
13339 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13340 decc_bug_fgetname = 1;
13342 decc_bug_fgetname = 0;
13345 /* UNIX directory names with no paths are broken in a lot of places */
13346 decc_dir_barename = 1;
13347 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13348 if ($VMS_STATUS_SUCCESS(status)) {
13349 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13350 decc_dir_barename = 1;
13352 decc_dir_barename = 0;
13355 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13356 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13358 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13359 if (decc_disable_to_vms_logname_translation < 0)
13360 decc_disable_to_vms_logname_translation = 0;
13363 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13365 decc_efs_case_preserve = decc$feature_get_value(s, 1);
13366 if (decc_efs_case_preserve < 0)
13367 decc_efs_case_preserve = 0;
13370 s = decc$feature_get_index("DECC$EFS_CHARSET");
13372 decc_efs_charset = decc$feature_get_value(s, 1);
13373 if (decc_efs_charset < 0)
13374 decc_efs_charset = 0;
13377 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13379 decc_filename_unix_report = decc$feature_get_value(s, 1);
13380 if (decc_filename_unix_report > 0)
13381 decc_filename_unix_report = 1;
13383 decc_filename_unix_report = 0;
13386 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13388 decc_filename_unix_only = decc$feature_get_value(s, 1);
13389 if (decc_filename_unix_only > 0) {
13390 decc_filename_unix_only = 1;
13393 decc_filename_unix_only = 0;
13397 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13399 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13400 if (decc_filename_unix_no_version < 0)
13401 decc_filename_unix_no_version = 0;
13404 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13406 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13407 if (decc_readdir_dropdotnotype < 0)
13408 decc_readdir_dropdotnotype = 0;
13411 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13412 if ($VMS_STATUS_SUCCESS(status)) {
13413 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13415 dflt = decc$feature_get_value(s, 4);
13417 decc_disable_posix_root = decc$feature_get_value(s, 1);
13418 if (decc_disable_posix_root <= 0) {
13419 decc$feature_set_value(s, 1, 1);
13420 decc_disable_posix_root = 1;
13424 /* Traditionally Perl assumes this is off */
13425 decc_disable_posix_root = 1;
13426 decc$feature_set_value(s, 1, 1);
13431 #if __CRTL_VER >= 80200000
13432 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13434 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13435 if (decc_posix_compliant_pathnames < 0)
13436 decc_posix_compliant_pathnames = 0;
13437 if (decc_posix_compliant_pathnames > 4)
13438 decc_posix_compliant_pathnames = 0;
13443 status = sys_trnlnm
13444 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13445 if ($VMS_STATUS_SUCCESS(status)) {
13446 val_str[0] = _toupper(val_str[0]);
13447 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13448 decc_disable_to_vms_logname_translation = 1;
13453 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13454 if ($VMS_STATUS_SUCCESS(status)) {
13455 val_str[0] = _toupper(val_str[0]);
13456 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13457 decc_efs_case_preserve = 1;
13462 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13463 if ($VMS_STATUS_SUCCESS(status)) {
13464 val_str[0] = _toupper(val_str[0]);
13465 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13466 decc_filename_unix_report = 1;
13469 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13470 if ($VMS_STATUS_SUCCESS(status)) {
13471 val_str[0] = _toupper(val_str[0]);
13472 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13473 decc_filename_unix_only = 1;
13474 decc_filename_unix_report = 1;
13477 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13478 if ($VMS_STATUS_SUCCESS(status)) {
13479 val_str[0] = _toupper(val_str[0]);
13480 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13481 decc_filename_unix_no_version = 1;
13484 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13485 if ($VMS_STATUS_SUCCESS(status)) {
13486 val_str[0] = _toupper(val_str[0]);
13487 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13488 decc_readdir_dropdotnotype = 1;
13493 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13495 /* Report true case tolerance */
13496 /*----------------------------*/
13497 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13498 if (!$VMS_STATUS_SUCCESS(status))
13499 case_perm = PPROP$K_CASE_BLIND;
13500 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13501 if (!$VMS_STATUS_SUCCESS(status))
13502 case_image = PPROP$K_CASE_BLIND;
13503 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13504 (case_image == PPROP$K_CASE_SENSITIVE))
13505 vms_process_case_tolerant = 0;
13510 /* CRTL can be initialized past this point, but not before. */
13511 /* DECC$CRTL_INIT(); */
13518 #pragma extern_model save
13519 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13520 const __align (LONGWORD) int spare[8] = {0};
13522 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13523 #if __DECC_VER >= 60560002
13524 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13526 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13528 #endif /* __DECC */
13530 const long vms_cc_features = (const long)set_features;
13533 ** Force a reference to LIB$INITIALIZE to ensure it
13534 ** exists in the image.
13536 int lib$initialize(void);
13538 #pragma extern_model strict_refdef
13540 int lib_init_ref = (int) lib$initialize;
13543 #pragma extern_model restore