3 * VMS-specific routines for perl5
5 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
6 * 2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
8 * You may distribute under the terms of either the GNU General Public
9 * License or the Artistic License, as specified in the README file.
11 * Please see Changes*.* or the Perl Repository Browser for revision history.
15 * Yet small as was their hunted band
16 * still fell and fearless was each hand,
17 * and strong deeds they wrought yet oft,
18 * and loved the woods, whose ways more soft
19 * them seemed than thralls of that black throne
20 * to live and languish in halls of stone.
21 * "The Lay of Leithian", Canto II, lines 135-40
23 * [p.162 of _The Lays of Beleriand_]
29 #if __CRTL_VER < 70300000
30 /* needed for home-rolled utime() */
36 #include <climsgdef.h>
46 #include <libclidef.h>
48 #include <lib$routines.h>
51 #if __CRTL_VER >= 70301000 && !defined(__VAX)
61 #include <str$routines.h>
67 #define NO_EFN EFN$C_ENF
69 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
70 int decc$feature_get_index(const char *name);
71 char* decc$feature_get_name(int index);
72 int decc$feature_get_value(int index, int mode);
73 int decc$feature_set_value(int index, int mode, int value);
78 #pragma member_alignment save
79 #pragma nomember_alignment longword
84 unsigned short * retadr;
86 #pragma member_alignment restore
88 /* Older versions of ssdef.h don't have these */
89 #ifndef SS$_INVFILFOROP
90 # define SS$_INVFILFOROP 3930
92 #ifndef SS$_NOSUCHOBJECT
93 # define SS$_NOSUCHOBJECT 2696
96 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
97 #define PERLIO_NOT_STDIO 0
99 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
100 * code below needs to get to the underlying CRTL routines. */
101 #define DONT_MASK_RTL_CALLS
105 /* Anticipating future expansion in lexical warnings . . . */
106 #ifndef WARN_INTERNAL
107 # define WARN_INTERNAL WARN_MISC
110 #ifdef VMS_LONGNAME_SUPPORT
111 #include <libfildef.h>
114 #if !defined(__VAX) && __CRTL_VER >= 80200000
122 #define lstat(_x, _y) stat(_x, _y)
125 /* Routine to create a decterm for use with the Perl debugger */
126 /* No headers, this information was found in the Programming Concepts Manual */
128 static int (*decw_term_port)
129 (const struct dsc$descriptor_s * display,
130 const struct dsc$descriptor_s * setup_file,
131 const struct dsc$descriptor_s * customization,
132 struct dsc$descriptor_s * result_device_name,
133 unsigned short * result_device_name_length,
136 void * char_change_buffer) = 0;
138 /* gcc's header files don't #define direct access macros
139 * corresponding to VAXC's variant structs */
141 # define uic$v_format uic$r_uic_form.uic$v_format
142 # define uic$v_group uic$r_uic_form.uic$v_group
143 # define uic$v_member uic$r_uic_form.uic$v_member
144 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
145 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
146 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
147 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
150 #if defined(NEED_AN_H_ERRNO)
154 #if defined(__DECC) || defined(__DECCXX)
155 #pragma member_alignment save
156 #pragma nomember_alignment longword
158 #pragma message disable misalgndmem
161 unsigned short int buflen;
162 unsigned short int itmcode;
164 unsigned short int *retlen;
167 struct filescan_itmlst_2 {
168 unsigned short length;
169 unsigned short itmcode;
174 unsigned short length;
175 char str[VMS_MAXRSS];
176 unsigned short pad; /* for longword struct alignment */
179 #if defined(__DECC) || defined(__DECCXX)
180 #pragma message restore
181 #pragma member_alignment restore
184 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
185 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
186 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
187 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
188 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
189 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
190 #define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
191 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
192 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
193 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
194 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
195 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
197 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
198 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
199 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
200 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
202 static char * int_rmsexpand_vms(
203 const char * filespec, char * outbuf, unsigned opts);
204 static char * int_rmsexpand_tovms(
205 const char * filespec, char * outbuf, unsigned opts);
206 static char *int_tovmsspec
207 (const char *path, char *buf, int dir_flag, int * utf8_flag);
208 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
209 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
210 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
212 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
213 #define PERL_LNM_MAX_ALLOWED_INDEX 127
215 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
216 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
219 #define PERL_LNM_MAX_ITER 10
221 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
222 #if __CRTL_VER >= 70302000 && !defined(__VAX)
223 #define MAX_DCL_SYMBOL (8192)
224 #define MAX_DCL_LINE_LENGTH (4096 - 4)
226 #define MAX_DCL_SYMBOL (1024)
227 #define MAX_DCL_LINE_LENGTH (1024 - 4)
230 static char *__mystrtolower(char *str)
232 if (str) for (; *str; ++str) *str= tolower(*str);
236 static struct dsc$descriptor_s fildevdsc =
237 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
238 static struct dsc$descriptor_s crtlenvdsc =
239 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
240 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
241 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
242 static struct dsc$descriptor_s **env_tables = defenv;
243 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
245 /* True if we shouldn't treat barewords as logicals during directory */
247 static int no_translate_barewords;
249 /* DECC Features that may need to affect how Perl interprets
250 * displays filename information
252 static int decc_disable_to_vms_logname_translation = 1;
253 static int decc_disable_posix_root = 1;
254 int decc_efs_case_preserve = 0;
255 static int decc_efs_charset = 0;
256 static int decc_efs_charset_index = -1;
257 static int decc_filename_unix_no_version = 0;
258 static int decc_filename_unix_only = 0;
259 int decc_filename_unix_report = 0;
260 int decc_posix_compliant_pathnames = 0;
261 int decc_readdir_dropdotnotype = 0;
262 static int vms_process_case_tolerant = 1;
263 int vms_vtf7_filenames = 0;
264 int gnv_unix_shell = 0;
265 static int vms_unlink_all_versions = 0;
266 static int vms_posix_exit = 0;
268 /* bug workarounds if needed */
269 int decc_bug_devnull = 1;
270 int decc_dir_barename = 0;
271 int vms_bug_stat_filename = 0;
273 static int vms_debug_on_exception = 0;
274 static int vms_debug_fileify = 0;
276 /* Simple logical name translation */
277 static int simple_trnlnm
278 (const char * logname,
282 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
283 const unsigned long attr = LNM$M_CASE_BLIND;
284 struct dsc$descriptor_s name_dsc;
286 unsigned short result;
287 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
290 name_dsc.dsc$w_length = strlen(logname);
291 name_dsc.dsc$a_pointer = (char *)logname;
292 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
293 name_dsc.dsc$b_class = DSC$K_CLASS_S;
295 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
297 if ($VMS_STATUS_SUCCESS(status)) {
299 /* Null terminate and return the string */
300 /*--------------------------------------*/
309 /* Is this a UNIX file specification?
310 * No longer a simple check with EFS file specs
311 * For now, not a full check, but need to
312 * handle POSIX ^UP^ specifications
313 * Fixing to handle ^/ cases would require
314 * changes to many other conversion routines.
317 static int is_unix_filespec(const char *path)
323 if (strncmp(path,"\"^UP^",5) != 0) {
324 pch1 = strchr(path, '/');
329 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
330 if (decc_filename_unix_report || decc_filename_unix_only) {
331 if (strcmp(path,".") == 0)
339 /* This routine converts a UCS-2 character to be VTF-7 encoded.
342 static void ucs2_to_vtf7
344 unsigned long ucs2_char,
347 unsigned char * ucs_ptr;
350 ucs_ptr = (unsigned char *)&ucs2_char;
354 hex = (ucs_ptr[1] >> 4) & 0xf;
356 outspec[2] = hex + '0';
358 outspec[2] = (hex - 9) + 'A';
359 hex = ucs_ptr[1] & 0xF;
361 outspec[3] = hex + '0';
363 outspec[3] = (hex - 9) + 'A';
365 hex = (ucs_ptr[0] >> 4) & 0xf;
367 outspec[4] = hex + '0';
369 outspec[4] = (hex - 9) + 'A';
370 hex = ucs_ptr[1] & 0xF;
372 outspec[5] = hex + '0';
374 outspec[5] = (hex - 9) + 'A';
380 /* This handles the conversion of a UNIX extended character set to a ^
381 * escaped VMS character.
382 * in a UNIX file specification.
384 * The output count variable contains the number of characters added
385 * to the output string.
387 * The return value is the number of characters read from the input string
389 static int copy_expand_unix_filename_escape
390 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
397 utf8_flag = *utf8_fl;
401 if (*inspec >= 0x80) {
402 if (utf8_fl && vms_vtf7_filenames) {
403 unsigned long ucs_char;
407 if ((*inspec & 0xE0) == 0xC0) {
409 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
410 if (ucs_char >= 0x80) {
411 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
414 } else if ((*inspec & 0xF0) == 0xE0) {
416 ucs_char = ((inspec[0] & 0xF) << 12) +
417 ((inspec[1] & 0x3f) << 6) +
419 if (ucs_char >= 0x800) {
420 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
424 #if 0 /* I do not see longer sequences supported by OpenVMS */
425 /* Maybe some one can fix this later */
426 } else if ((*inspec & 0xF8) == 0xF0) {
429 } else if ((*inspec & 0xFC) == 0xF8) {
432 } else if ((*inspec & 0xFE) == 0xFC) {
439 /* High bit set, but not a Unicode character! */
441 /* Non printing DECMCS or ISO Latin-1 character? */
442 if ((unsigned char)*inspec <= 0x9F) {
446 hex = (*inspec >> 4) & 0xF;
448 outspec[1] = hex + '0';
450 outspec[1] = (hex - 9) + 'A';
454 outspec[2] = hex + '0';
456 outspec[2] = (hex - 9) + 'A';
460 } else if ((unsigned char)*inspec == 0xA0) {
466 } else if ((unsigned char)*inspec == 0xFF) {
478 /* Is this a macro that needs to be passed through?
479 * Macros start with $( and an alpha character, followed
480 * by a string of alpha numeric characters ending with a )
481 * If this does not match, then encode it as ODS-5.
483 if ((inspec[0] == '$') && (inspec[1] == '(')) {
486 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
488 outspec[0] = inspec[0];
489 outspec[1] = inspec[1];
490 outspec[2] = inspec[2];
492 while(isalnum(inspec[tcnt]) ||
493 (inspec[2] == '.') || (inspec[2] == '_')) {
494 outspec[tcnt] = inspec[tcnt];
497 if (inspec[tcnt] == ')') {
498 outspec[tcnt] = inspec[tcnt];
515 if (decc_efs_charset == 0)
542 /* Don't escape again if following character is
543 * already something we escape.
545 if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
551 /* But otherwise fall through and escape it. */
553 /* Assume that this is to be escaped */
555 outspec[1] = *inspec;
559 case ' ': /* space */
560 /* Assume that this is to be escaped */
576 /* This handles the expansion of a '^' prefix to the proper character
577 * in a UNIX file specification.
579 * The output count variable contains the number of characters added
580 * to the output string.
582 * The return value is the number of characters read from the input
585 static int copy_expand_vms_filename_escape
586 (char *outspec, const char *inspec, int *output_cnt)
593 if (*inspec == '^') {
596 /* Spaces and non-trailing dots should just be passed through,
597 * but eat the escape character.
604 case '_': /* space */
610 /* Hmm. Better leave the escape escaped. */
616 case 'U': /* Unicode - FIX-ME this is wrong. */
619 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
622 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
623 outspec[0] = c1 & 0xff;
624 outspec[1] = c2 & 0xff;
631 /* Error - do best we can to continue */
641 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
645 scnt = sscanf(inspec, "%2x", &c1);
646 outspec[0] = c1 & 0xff;
667 /* vms_split_path - Verify that the input file specification is a
668 * VMS format file specification, and provide pointers to the components of
669 * it. With EFS format filenames, this is virtually the only way to
670 * parse a VMS path specification into components.
672 * If the sum of the components do not add up to the length of the
673 * string, then the passed file specification is probably a UNIX style
676 static int vms_split_path
691 struct dsc$descriptor path_desc;
695 struct filescan_itmlst_2 item_list[9];
696 const int filespec = 0;
697 const int nodespec = 1;
698 const int devspec = 2;
699 const int rootspec = 3;
700 const int dirspec = 4;
701 const int namespec = 5;
702 const int typespec = 6;
703 const int verspec = 7;
705 /* Assume the worst for an easy exit */
719 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
720 path_desc.dsc$w_length = strlen(path);
721 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
722 path_desc.dsc$b_class = DSC$K_CLASS_S;
724 /* Get the total length, if it is shorter than the string passed
725 * then this was probably not a VMS formatted file specification
727 item_list[filespec].itmcode = FSCN$_FILESPEC;
728 item_list[filespec].length = 0;
729 item_list[filespec].component = NULL;
731 /* If the node is present, then it gets considered as part of the
732 * volume name to hopefully make things simple.
734 item_list[nodespec].itmcode = FSCN$_NODE;
735 item_list[nodespec].length = 0;
736 item_list[nodespec].component = NULL;
738 item_list[devspec].itmcode = FSCN$_DEVICE;
739 item_list[devspec].length = 0;
740 item_list[devspec].component = NULL;
742 /* root is a special case, adding it to either the directory or
743 * the device components will probably complicate things for the
744 * callers of this routine, so leave it separate.
746 item_list[rootspec].itmcode = FSCN$_ROOT;
747 item_list[rootspec].length = 0;
748 item_list[rootspec].component = NULL;
750 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
751 item_list[dirspec].length = 0;
752 item_list[dirspec].component = NULL;
754 item_list[namespec].itmcode = FSCN$_NAME;
755 item_list[namespec].length = 0;
756 item_list[namespec].component = NULL;
758 item_list[typespec].itmcode = FSCN$_TYPE;
759 item_list[typespec].length = 0;
760 item_list[typespec].component = NULL;
762 item_list[verspec].itmcode = FSCN$_VERSION;
763 item_list[verspec].length = 0;
764 item_list[verspec].component = NULL;
766 item_list[8].itmcode = 0;
767 item_list[8].length = 0;
768 item_list[8].component = NULL;
770 status = sys$filescan
771 ((const struct dsc$descriptor_s *)&path_desc, item_list,
773 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
775 /* If we parsed it successfully these two lengths should be the same */
776 if (path_desc.dsc$w_length != item_list[filespec].length)
779 /* If we got here, then it is a VMS file specification */
782 /* set the volume name */
783 if (item_list[nodespec].length > 0) {
784 *volume = item_list[nodespec].component;
785 *vol_len = item_list[nodespec].length + item_list[devspec].length;
788 *volume = item_list[devspec].component;
789 *vol_len = item_list[devspec].length;
792 *root = item_list[rootspec].component;
793 *root_len = item_list[rootspec].length;
795 *dir = item_list[dirspec].component;
796 *dir_len = item_list[dirspec].length;
798 /* Now fun with versions and EFS file specifications
799 * The parser can not tell the difference when a "." is a version
800 * delimiter or a part of the file specification.
802 if ((decc_efs_charset) &&
803 (item_list[verspec].length > 0) &&
804 (item_list[verspec].component[0] == '.')) {
805 *name = item_list[namespec].component;
806 *name_len = item_list[namespec].length + item_list[typespec].length;
807 *ext = item_list[verspec].component;
808 *ext_len = item_list[verspec].length;
813 *name = item_list[namespec].component;
814 *name_len = item_list[namespec].length;
815 *ext = item_list[typespec].component;
816 *ext_len = item_list[typespec].length;
817 *version = item_list[verspec].component;
818 *ver_len = item_list[verspec].length;
823 /* Routine to determine if the file specification ends with .dir */
824 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
826 /* e_len must be 4, and version must be <= 2 characters */
827 if (e_len != 4 || vs_len > 2)
830 /* If a version number is present, it needs to be one */
831 if ((vs_len == 2) && (vs_spec[1] != '1'))
834 /* Look for the DIR on the extension */
835 if (vms_process_case_tolerant) {
836 if ((toupper(e_spec[1]) == 'D') &&
837 (toupper(e_spec[2]) == 'I') &&
838 (toupper(e_spec[3]) == 'R')) {
842 /* Directory extensions are supposed to be in upper case only */
843 /* I would not be surprised if this rule can not be enforced */
844 /* if and when someone fully debugs the case sensitive mode */
845 if ((e_spec[1] == 'D') &&
846 (e_spec[2] == 'I') &&
847 (e_spec[3] == 'R')) {
856 * Routine to retrieve the maximum equivalence index for an input
857 * logical name. Some calls to this routine have no knowledge if
858 * the variable is a logical or not. So on error we return a max
861 /*{{{int my_maxidx(const char *lnm) */
863 my_maxidx(const char *lnm)
867 int attr = LNM$M_CASE_BLIND;
868 struct dsc$descriptor lnmdsc;
869 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
872 lnmdsc.dsc$w_length = strlen(lnm);
873 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
874 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
875 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
877 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
878 if ((status & 1) == 0)
885 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
887 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
888 struct dsc$descriptor_s **tabvec, unsigned long int flags)
891 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
892 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
893 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
895 unsigned char acmode;
896 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
897 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
898 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
899 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
901 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
902 #if defined(PERL_IMPLICIT_CONTEXT)
905 aTHX = PERL_GET_INTERP;
911 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
912 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
914 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
915 *cp2 = _toupper(*cp1);
916 if (cp1 - lnm > LNM$C_NAMLENGTH) {
917 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
921 lnmdsc.dsc$w_length = cp1 - lnm;
922 lnmdsc.dsc$a_pointer = uplnm;
923 uplnm[lnmdsc.dsc$w_length] = '\0';
924 secure = flags & PERL__TRNENV_SECURE;
925 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
926 if (!tabvec || !*tabvec) tabvec = env_tables;
928 for (curtab = 0; tabvec[curtab]; curtab++) {
929 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
930 if (!ivenv && !secure) {
935 #if defined(PERL_IMPLICIT_CONTEXT)
938 "Can't read CRTL environ\n");
941 Perl_warn(aTHX_ "Can't read CRTL environ\n");
944 retsts = SS$_NOLOGNAM;
945 for (i = 0; environ[i]; i++) {
946 if ((eq = strchr(environ[i],'=')) &&
947 lnmdsc.dsc$w_length == (eq - environ[i]) &&
948 !strncmp(environ[i],uplnm,eq - environ[i])) {
950 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
951 if (!eqvlen) continue;
956 if (retsts != SS$_NOLOGNAM) break;
959 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
960 !str$case_blind_compare(&tmpdsc,&clisym)) {
961 if (!ivsym && !secure) {
962 unsigned short int deflen = LNM$C_NAMLENGTH;
963 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
964 /* dynamic dsc to accommodate possible long value */
965 _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
966 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
968 if (eqvlen > MAX_DCL_SYMBOL) {
969 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
970 eqvlen = MAX_DCL_SYMBOL;
971 /* Special hack--we might be called before the interpreter's */
972 /* fully initialized, in which case either thr or PL_curcop */
973 /* might be bogus. We have to check, since ckWARN needs them */
974 /* both to be valid if running threaded */
975 #if defined(PERL_IMPLICIT_CONTEXT)
978 "Value of CLI symbol \"%s\" too long",lnm);
981 if (ckWARN(WARN_MISC)) {
982 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
985 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
987 _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
988 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
989 if (retsts == LIB$_NOSUCHSYM) continue;
994 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
995 midx = my_maxidx(lnm);
996 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
997 lnmlst[1].bufadr = cp2;
999 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1000 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1001 if (retsts == SS$_NOLOGNAM) break;
1002 /* PPFs have a prefix */
1005 *((int *)uplnm) == *((int *)"SYS$") &&
1007 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1008 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1009 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1010 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1011 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
1012 memmove(eqv,eqv+4,eqvlen-4);
1018 if ((retsts == SS$_IVLOGNAM) ||
1019 (retsts == SS$_NOLOGNAM)) { continue; }
1022 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1023 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1024 if (retsts == SS$_NOLOGNAM) continue;
1027 eqvlen = strlen(eqv);
1031 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1032 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1033 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1034 retsts == SS$_NOLOGNAM) {
1035 set_errno(EINVAL); set_vaxc_errno(retsts);
1037 else _ckvmssts_noperl(retsts);
1039 } /* end of vmstrnenv */
1042 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1043 /* Define as a function so we can access statics. */
1044 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1048 #if defined(PERL_IMPLICIT_CONTEXT)
1051 #ifdef SECURE_INTERNAL_GETENV
1052 flags = (PL_curinterp ? TAINTING_get : will_taint) ?
1053 PERL__TRNENV_SECURE : 0;
1056 return vmstrnenv(lnm, eqv, idx, fildev, flags);
1061 * Note: Uses Perl temp to store result so char * can be returned to
1062 * caller; this pointer will be invalidated at next Perl statement
1064 * We define this as a function rather than a macro in terms of my_getenv_len()
1065 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1068 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1070 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1073 static char *__my_getenv_eqv = NULL;
1074 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1075 unsigned long int idx = 0;
1076 int success, secure, saverr, savvmserr;
1080 midx = my_maxidx(lnm) + 1;
1082 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1083 /* Set up a temporary buffer for the return value; Perl will
1084 * clean it up at the next statement transition */
1085 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1086 if (!tmpsv) return NULL;
1090 /* Assume no interpreter ==> single thread */
1091 if (__my_getenv_eqv != NULL) {
1092 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1095 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1097 eqv = __my_getenv_eqv;
1100 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1101 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1103 getcwd(eqv,LNM$C_NAMLENGTH);
1107 /* Get rid of "000000/ in rooted filespecs */
1110 zeros = strstr(eqv, "/000000/");
1111 if (zeros != NULL) {
1113 mlen = len - (zeros - eqv) - 7;
1114 memmove(zeros, &zeros[7], mlen);
1122 /* Impose security constraints only if tainting */
1124 /* Impose security constraints only if tainting */
1125 secure = PL_curinterp ? TAINTING_get : will_taint;
1126 saverr = errno; savvmserr = vaxc$errno;
1133 #ifdef SECURE_INTERNAL_GETENV
1134 secure ? PERL__TRNENV_SECURE : 0
1140 /* For the getenv interface we combine all the equivalence names
1141 * of a search list logical into one value to acquire a maximum
1142 * value length of 255*128 (assuming %ENV is using logicals).
1144 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1146 /* If the name contains a semicolon-delimited index, parse it
1147 * off and make sure we only retrieve the equivalence name for
1149 if ((cp2 = strchr(lnm,';')) != NULL) {
1150 my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1151 idx = strtoul(cp2+1,NULL,0);
1153 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1156 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1158 /* Discard NOLOGNAM on internal calls since we're often looking
1159 * for an optional name, and this "error" often shows up as the
1160 * (bogus) exit status for a die() call later on. */
1161 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1162 return success ? eqv : NULL;
1165 } /* end of my_getenv() */
1169 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1171 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1175 unsigned long idx = 0;
1177 static char *__my_getenv_len_eqv = NULL;
1178 int secure, saverr, savvmserr;
1181 midx = my_maxidx(lnm) + 1;
1183 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1184 /* Set up a temporary buffer for the return value; Perl will
1185 * clean it up at the next statement transition */
1186 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1187 if (!tmpsv) return NULL;
1191 /* Assume no interpreter ==> single thread */
1192 if (__my_getenv_len_eqv != NULL) {
1193 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1196 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1198 buf = __my_getenv_len_eqv;
1201 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1202 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1205 getcwd(buf,LNM$C_NAMLENGTH);
1208 /* Get rid of "000000/ in rooted filespecs */
1210 zeros = strstr(buf, "/000000/");
1211 if (zeros != NULL) {
1213 mlen = *len - (zeros - buf) - 7;
1214 memmove(zeros, &zeros[7], mlen);
1223 /* Impose security constraints only if tainting */
1224 secure = PL_curinterp ? TAINTING_get : will_taint;
1225 saverr = errno; savvmserr = vaxc$errno;
1232 #ifdef SECURE_INTERNAL_GETENV
1233 secure ? PERL__TRNENV_SECURE : 0
1239 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1241 if ((cp2 = strchr(lnm,';')) != NULL) {
1242 my_strlcpy(buf, lnm, cp2 - lnm + 1);
1243 idx = strtoul(cp2+1,NULL,0);
1245 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1248 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1250 /* Get rid of "000000/ in rooted filespecs */
1253 zeros = strstr(buf, "/000000/");
1254 if (zeros != NULL) {
1256 mlen = *len - (zeros - buf) - 7;
1257 memmove(zeros, &zeros[7], mlen);
1263 /* Discard NOLOGNAM on internal calls since we're often looking
1264 * for an optional name, and this "error" often shows up as the
1265 * (bogus) exit status for a die() call later on. */
1266 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1267 return *len ? buf : NULL;
1270 } /* end of my_getenv_len() */
1273 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1275 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1277 /*{{{ void prime_env_iter() */
1279 prime_env_iter(void)
1280 /* Fill the %ENV associative array with all logical names we can
1281 * find, in preparation for iterating over it.
1284 static int primed = 0;
1285 HV *seenhv = NULL, *envhv;
1287 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1288 unsigned short int chan;
1289 #ifndef CLI$M_TRUSTED
1290 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1292 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1293 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1295 bool have_sym = FALSE, have_lnm = FALSE;
1296 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1297 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1298 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1299 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1300 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1301 #if defined(PERL_IMPLICIT_CONTEXT)
1304 #if defined(USE_ITHREADS)
1305 static perl_mutex primenv_mutex;
1306 MUTEX_INIT(&primenv_mutex);
1309 #if defined(PERL_IMPLICIT_CONTEXT)
1310 /* We jump through these hoops because we can be called at */
1311 /* platform-specific initialization time, which is before anything is */
1312 /* set up--we can't even do a plain dTHX since that relies on the */
1313 /* interpreter structure to be initialized */
1315 aTHX = PERL_GET_INTERP;
1317 /* we never get here because the NULL pointer will cause the */
1318 /* several of the routines called by this routine to access violate */
1320 /* This routine is only called by hv.c/hv_iterinit which has a */
1321 /* context, so the real fix may be to pass it through instead of */
1322 /* the hoops above */
1327 if (primed || !PL_envgv) return;
1328 MUTEX_LOCK(&primenv_mutex);
1329 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1330 envhv = GvHVn(PL_envgv);
1331 /* Perform a dummy fetch as an lval to insure that the hash table is
1332 * set up. Otherwise, the hv_store() will turn into a nullop. */
1333 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1335 for (i = 0; env_tables[i]; i++) {
1336 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1337 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1338 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1340 if (have_sym || have_lnm) {
1341 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1342 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1343 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1344 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1347 for (i--; i >= 0; i--) {
1348 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1351 for (j = 0; environ[j]; j++) {
1352 if (!(start = strchr(environ[j],'='))) {
1353 if (ckWARN(WARN_INTERNAL))
1354 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1358 sv = newSVpv(start,0);
1360 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1365 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1366 !str$case_blind_compare(&tmpdsc,&clisym)) {
1367 my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1368 cmddsc.dsc$w_length = 20;
1369 if (env_tables[i]->dsc$w_length == 12 &&
1370 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1371 !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local *", sizeof(cmd)-12);
1372 flags = defflags | CLI$M_NOLOGNAM;
1375 my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1376 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1377 my_strlcat(cmd," /Table=", sizeof(cmd));
1378 cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, env_tables[i]->dsc$w_length + 1);
1380 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1381 flags = defflags | CLI$M_NOCLISYM;
1384 /* Create a new subprocess to execute each command, to exclude the
1385 * remote possibility that someone could subvert a mbx or file used
1386 * to write multiple commands to a single subprocess.
1389 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1390 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1391 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1392 defflags &= ~CLI$M_TRUSTED;
1393 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1395 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1396 if (seenhv) SvREFCNT_dec(seenhv);
1399 char *cp1, *cp2, *key;
1400 unsigned long int sts, iosb[2], retlen, keylen;
1403 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1404 if (sts & 1) sts = iosb[0] & 0xffff;
1405 if (sts == SS$_ENDOFFILE) {
1407 while (substs == 0) { sys$hiber(); wakect++;}
1408 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1413 retlen = iosb[0] >> 16;
1414 if (!retlen) continue; /* blank line */
1416 if (iosb[1] != subpid) {
1418 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1422 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1423 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1425 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1426 if (*cp1 == '(' || /* Logical name table name */
1427 *cp1 == '=' /* Next eqv of searchlist */) continue;
1428 if (*cp1 == '"') cp1++;
1429 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1430 key = cp1; keylen = cp2 - cp1;
1431 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1432 while (*cp2 && *cp2 != '=') cp2++;
1433 while (*cp2 && *cp2 == '=') cp2++;
1434 while (*cp2 && *cp2 == ' ') cp2++;
1435 if (*cp2 == '"') { /* String translation; may embed "" */
1436 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1437 cp2++; cp1--; /* Skip "" surrounding translation */
1439 else { /* Numeric translation */
1440 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1441 cp1--; /* stop on last non-space char */
1443 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1444 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1447 PERL_HASH(hash,key,keylen);
1449 if (cp1 == cp2 && *cp2 == '.') {
1450 /* A single dot usually means an unprintable character, such as a null
1451 * to indicate a zero-length value. Get the actual value to make sure.
1453 char lnm[LNM$C_NAMLENGTH+1];
1454 char eqv[MAX_DCL_SYMBOL+1];
1456 strncpy(lnm, key, keylen);
1457 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1458 sv = newSVpvn(eqv, strlen(eqv));
1461 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1465 hv_store(envhv,key,keylen,sv,hash);
1466 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1468 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1469 /* get the PPFs for this process, not the subprocess */
1470 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1471 char eqv[LNM$C_NAMLENGTH+1];
1473 for (i = 0; ppfs[i]; i++) {
1474 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1475 sv = newSVpv(eqv,trnlen);
1477 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1482 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1483 if (buf) Safefree(buf);
1484 if (seenhv) SvREFCNT_dec(seenhv);
1485 MUTEX_UNLOCK(&primenv_mutex);
1488 } /* end of prime_env_iter */
1492 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1493 /* Define or delete an element in the same "environment" as
1494 * vmstrnenv(). If an element is to be deleted, it's removed from
1495 * the first place it's found. If it's to be set, it's set in the
1496 * place designated by the first element of the table vector.
1497 * Like setenv() returns 0 for success, non-zero on error.
1500 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1503 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1504 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1506 unsigned long int retsts, usermode = PSL$C_USER;
1507 struct itmlst_3 *ile, *ilist;
1508 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1509 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1510 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1511 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1512 $DESCRIPTOR(local,"_LOCAL");
1515 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1516 return SS$_IVLOGNAM;
1519 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1520 *cp2 = _toupper(*cp1);
1521 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1522 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1523 return SS$_IVLOGNAM;
1526 lnmdsc.dsc$w_length = cp1 - lnm;
1527 if (!tabvec || !*tabvec) tabvec = env_tables;
1529 if (!eqv) { /* we're deleting n element */
1530 for (curtab = 0; tabvec[curtab]; curtab++) {
1531 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1533 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1534 if ((cp1 = strchr(environ[i],'=')) &&
1535 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1536 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1538 return setenv(lnm,"",1) ? vaxc$errno : 0;
1541 ivenv = 1; retsts = SS$_NOLOGNAM;
1543 if (ckWARN(WARN_INTERNAL))
1544 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1545 ivenv = 1; retsts = SS$_NOSUCHPGM;
1551 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1552 !str$case_blind_compare(&tmpdsc,&clisym)) {
1553 unsigned int symtype;
1554 if (tabvec[curtab]->dsc$w_length == 12 &&
1555 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1556 !str$case_blind_compare(&tmpdsc,&local))
1557 symtype = LIB$K_CLI_LOCAL_SYM;
1558 else symtype = LIB$K_CLI_GLOBAL_SYM;
1559 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1560 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1561 if (retsts == LIB$_NOSUCHSYM) continue;
1565 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1566 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1567 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1568 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1569 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1573 else { /* we're defining a value */
1574 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1576 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1578 if (ckWARN(WARN_INTERNAL))
1579 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1580 retsts = SS$_NOSUCHPGM;
1584 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1585 eqvdsc.dsc$w_length = strlen(eqv);
1586 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1587 !str$case_blind_compare(&tmpdsc,&clisym)) {
1588 unsigned int symtype;
1589 if (tabvec[0]->dsc$w_length == 12 &&
1590 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1591 !str$case_blind_compare(&tmpdsc,&local))
1592 symtype = LIB$K_CLI_LOCAL_SYM;
1593 else symtype = LIB$K_CLI_GLOBAL_SYM;
1594 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1597 if (!*eqv) eqvdsc.dsc$w_length = 1;
1598 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1600 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1601 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1602 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1603 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1604 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1605 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1608 Newx(ilist,nseg+1,struct itmlst_3);
1611 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1614 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1616 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1617 ile->itmcode = LNM$_STRING;
1619 if ((j+1) == nseg) {
1620 ile->buflen = strlen(c);
1621 /* in case we are truncating one that's too long */
1622 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1625 ile->buflen = LNM$C_NAMLENGTH;
1629 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1633 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1638 if (!(retsts & 1)) {
1640 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1641 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1642 set_errno(EVMSERR); break;
1643 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1644 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1645 set_errno(EINVAL); break;
1647 set_errno(EACCES); break;
1652 set_vaxc_errno(retsts);
1653 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1656 /* We reset error values on success because Perl does an hv_fetch()
1657 * before each hv_store(), and if the thing we're setting didn't
1658 * previously exist, we've got a leftover error message. (Of course,
1659 * this fails in the face of
1660 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1661 * in that the error reported in $! isn't spurious,
1662 * but it's right more often than not.)
1664 set_errno(0); set_vaxc_errno(retsts);
1668 } /* end of vmssetenv() */
1671 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1672 /* This has to be a function since there's a prototype for it in proto.h */
1674 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1677 int len = strlen(lnm);
1681 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1682 if (!strcmp(uplnm,"DEFAULT")) {
1683 if (eqv && *eqv) my_chdir(eqv);
1688 (void) vmssetenv(lnm,eqv,NULL);
1692 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1694 * sets a user-mode logical in the process logical name table
1695 * used for redirection of sys$error
1698 Perl_vmssetuserlnm(const char *name, const char *eqv)
1700 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1701 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1702 unsigned long int iss, attr = LNM$M_CONFINE;
1703 unsigned char acmode = PSL$C_USER;
1704 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1706 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1707 d_name.dsc$w_length = strlen(name);
1709 lnmlst[0].buflen = strlen(eqv);
1710 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1712 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1713 if (!(iss&1)) lib$signal(iss);
1718 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1719 /* my_crypt - VMS password hashing
1720 * my_crypt() provides an interface compatible with the Unix crypt()
1721 * C library function, and uses sys$hash_password() to perform VMS
1722 * password hashing. The quadword hashed password value is returned
1723 * as a NUL-terminated 8 character string. my_crypt() does not change
1724 * the case of its string arguments; in order to match the behavior
1725 * of LOGINOUT et al., alphabetic characters in both arguments must
1726 * be upcased by the caller.
1728 * - fix me to call ACM services when available
1731 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1733 # ifndef UAI$C_PREFERRED_ALGORITHM
1734 # define UAI$C_PREFERRED_ALGORITHM 127
1736 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1737 unsigned short int salt = 0;
1738 unsigned long int sts;
1740 unsigned short int dsc$w_length;
1741 unsigned char dsc$b_type;
1742 unsigned char dsc$b_class;
1743 const char * dsc$a_pointer;
1744 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1745 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1746 struct itmlst_3 uailst[3] = {
1747 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1748 { sizeof salt, UAI$_SALT, &salt, 0},
1749 { 0, 0, NULL, NULL}};
1750 static char hash[9];
1752 usrdsc.dsc$w_length = strlen(usrname);
1753 usrdsc.dsc$a_pointer = usrname;
1754 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1756 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1760 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1765 set_vaxc_errno(sts);
1766 if (sts != RMS$_RNF) return NULL;
1769 txtdsc.dsc$w_length = strlen(textpasswd);
1770 txtdsc.dsc$a_pointer = textpasswd;
1771 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1772 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1775 return (char *) hash;
1777 } /* end of my_crypt() */
1781 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1782 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1783 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1785 /* fixup barenames that are directories for internal use.
1786 * There have been problems with the consistent handling of UNIX
1787 * style directory names when routines are presented with a name that
1788 * has no directory delimiters at all. So this routine will eventually
1791 static char * fixup_bare_dirnames(const char * name)
1793 if (decc_disable_to_vms_logname_translation) {
1799 /* 8.3, remove() is now broken on symbolic links */
1800 static int rms_erase(const char * vmsname);
1804 * A little hack to get around a bug in some implementation of remove()
1805 * that do not know how to delete a directory
1807 * Delete any file to which user has control access, regardless of whether
1808 * delete access is explicitly allowed.
1809 * Limitations: User must have write access to parent directory.
1810 * Does not block signals or ASTs; if interrupted in midstream
1811 * may leave file with an altered ACL.
1814 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1816 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1820 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1821 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1822 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1824 unsigned char myace$b_length;
1825 unsigned char myace$b_type;
1826 unsigned short int myace$w_flags;
1827 unsigned long int myace$l_access;
1828 unsigned long int myace$l_ident;
1829 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1830 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1831 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1833 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1834 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1835 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1836 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1837 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1838 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1840 /* Expand the input spec using RMS, since the CRTL remove() and
1841 * system services won't do this by themselves, so we may miss
1842 * a file "hiding" behind a logical name or search list. */
1843 vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1844 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1846 rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1848 PerlMem_free(vmsname);
1852 /* Erase the file */
1853 rmsts = rms_erase(vmsname);
1855 /* Did it succeed */
1856 if ($VMS_STATUS_SUCCESS(rmsts)) {
1857 PerlMem_free(vmsname);
1861 /* If not, can changing protections help? */
1862 if (rmsts != RMS$_PRV) {
1863 set_vaxc_errno(rmsts);
1864 PerlMem_free(vmsname);
1868 /* No, so we get our own UIC to use as a rights identifier,
1869 * and the insert an ACE at the head of the ACL which allows us
1870 * to delete the file.
1872 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1873 fildsc.dsc$w_length = strlen(vmsname);
1874 fildsc.dsc$a_pointer = vmsname;
1876 newace.myace$l_ident = oldace.myace$l_ident;
1878 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1880 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1881 set_errno(ENOENT); break;
1883 set_errno(ENOTDIR); break;
1885 set_errno(ENODEV); break;
1886 case RMS$_SYN: case SS$_INVFILFOROP:
1887 set_errno(EINVAL); break;
1889 set_errno(EACCES); break;
1891 _ckvmssts_noperl(aclsts);
1893 set_vaxc_errno(aclsts);
1894 PerlMem_free(vmsname);
1897 /* Grab any existing ACEs with this identifier in case we fail */
1898 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1899 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1900 || fndsts == SS$_NOMOREACE ) {
1901 /* Add the new ACE . . . */
1902 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1905 rmsts = rms_erase(vmsname);
1906 if ($VMS_STATUS_SUCCESS(rmsts)) {
1911 /* We blew it - dir with files in it, no write priv for
1912 * parent directory, etc. Put things back the way they were. */
1913 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1916 addlst[0].bufadr = &oldace;
1917 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1924 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1925 /* We just deleted it, so of course it's not there. Some versions of
1926 * VMS seem to return success on the unlock operation anyhow (after all
1927 * the unlock is successful), but others don't.
1929 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1930 if (aclsts & 1) aclsts = fndsts;
1931 if (!(aclsts & 1)) {
1933 set_vaxc_errno(aclsts);
1936 PerlMem_free(vmsname);
1939 } /* end of kill_file() */
1943 /*{{{int do_rmdir(char *name)*/
1945 Perl_do_rmdir(pTHX_ const char *name)
1951 /* lstat returns a VMS fileified specification of the name */
1952 /* that is looked up, and also lets verifies that this is a directory */
1954 retval = flex_lstat(name, &st);
1958 /* Due to a historical feature, flex_stat/lstat can not see some */
1959 /* Unix format file names that the rest of the CRTL can see */
1960 /* Fixing that feature will cause some perl tests to fail */
1961 /* So try this one more time. */
1963 retval = lstat(name, &st.crtl_stat);
1967 /* force it to a file spec for the kill file to work. */
1968 ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1969 if (ret_spec == NULL) {
1975 if (!S_ISDIR(st.st_mode)) {
1980 dirfile = st.st_devnam;
1982 /* It may be possible for flex_stat to find a file and vmsify() to */
1983 /* fail with ODS-2 specifications. mp_do_kill_file can not deal */
1984 /* with that case, so fail it */
1985 if (dirfile[0] == 0) {
1990 retval = mp_do_kill_file(aTHX_ dirfile, 1);
1995 } /* end of do_rmdir */
1999 * Delete any file to which user has control access, regardless of whether
2000 * delete access is explicitly allowed.
2001 * Limitations: User must have write access to parent directory.
2002 * Does not block signals or ASTs; if interrupted in midstream
2003 * may leave file with an altered ACL.
2006 /*{{{int kill_file(char *name)*/
2008 Perl_kill_file(pTHX_ const char *name)
2014 /* Convert the filename to VMS format and see if it is a directory */
2015 /* flex_lstat returns a vmsified file specification */
2016 rmsts = flex_lstat(name, &st);
2019 /* Due to a historical feature, flex_stat/lstat can not see some */
2020 /* Unix format file names that the rest of the CRTL can see when */
2021 /* ODS-2 file specifications are in use. */
2022 /* Fixing that feature will cause some perl tests to fail */
2023 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2025 vmsfile = (char *) name; /* cast ok */
2028 vmsfile = st.st_devnam;
2029 if (vmsfile[0] == 0) {
2030 /* It may be possible for flex_stat to find a file and vmsify() */
2031 /* to fail with ODS-2 specifications. mp_do_kill_file can not */
2032 /* deal with that case, so fail it */
2038 /* Remove() is allowed to delete directories, according to the X/Open
2040 * This may need special handling to work with the ACL hacks.
2042 if (S_ISDIR(st.st_mode)) {
2043 rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2047 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2049 /* Need to delete all versions ? */
2050 if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2053 /* Just use lstat() here as do not need st_dev */
2054 /* and we know that the file is in VMS format or that */
2055 /* because of a historical bug, flex_stat can not see the file */
2056 while (lstat(vmsfile, (stat_t *)&st) == 0) {
2057 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2062 /* Make sure that we do not loop forever */
2073 } /* end of kill_file() */
2077 /*{{{int my_mkdir(char *,Mode_t)*/
2079 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2081 STRLEN dirlen = strlen(dir);
2083 /* zero length string sometimes gives ACCVIO */
2084 if (dirlen == 0) return -1;
2086 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2087 * null file name/type. However, it's commonplace under Unix,
2088 * so we'll allow it for a gain in portability.
2090 if (dir[dirlen-1] == '/') {
2091 char *newdir = savepvn(dir,dirlen-1);
2092 int ret = mkdir(newdir,mode);
2096 else return mkdir(dir,mode);
2097 } /* end of my_mkdir */
2100 /*{{{int my_chdir(char *)*/
2102 Perl_my_chdir(pTHX_ const char *dir)
2104 STRLEN dirlen = strlen(dir);
2106 /* zero length string sometimes gives ACCVIO */
2107 if (dirlen == 0) return -1;
2110 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2111 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2112 * so that existing scripts do not need to be changed.
2115 while ((dirlen > 0) && (*dir1 == ' ')) {
2120 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2122 * null file name/type. However, it's commonplace under Unix,
2123 * so we'll allow it for a gain in portability.
2125 * '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2127 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2130 newdir = (char *)PerlMem_malloc(dirlen);
2132 _ckvmssts_noperl(SS$_INSFMEM);
2133 memcpy(newdir, dir1, dirlen-1);
2134 newdir[dirlen-1] = '\0';
2135 ret = chdir(newdir);
2136 PerlMem_free(newdir);
2139 else return chdir(dir1);
2140 } /* end of my_chdir */
2144 /*{{{int my_chmod(char *, mode_t)*/
2146 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2151 STRLEN speclen = strlen(file_spec);
2153 /* zero length string sometimes gives ACCVIO */
2154 if (speclen == 0) return -1;
2156 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2157 * that implies null file name/type. However, it's commonplace under Unix,
2158 * so we'll allow it for a gain in portability.
2160 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2161 * in VMS file.dir notation.
2163 changefile = (char *) file_spec; /* cast ok */
2164 ret = flex_lstat(file_spec, &st);
2167 /* Due to a historical feature, flex_stat/lstat can not see some */
2168 /* Unix format file names that the rest of the CRTL can see when */
2169 /* ODS-2 file specifications are in use. */
2170 /* Fixing that feature will cause some perl tests to fail */
2171 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2175 /* It may be possible to get here with nothing in st_devname */
2176 /* chmod still may work though */
2177 if (st.st_devnam[0] != 0) {
2178 changefile = st.st_devnam;
2181 ret = chmod(changefile, mode);
2183 } /* end of my_chmod */
2187 /*{{{FILE *my_tmpfile()*/
2194 if ((fp = tmpfile())) return fp;
2196 cp = (char *)PerlMem_malloc(L_tmpnam+24);
2197 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2199 if (decc_filename_unix_only == 0)
2200 strcpy(cp,"Sys$Scratch:");
2203 tmpnam(cp+strlen(cp));
2204 strcat(cp,".Perltmp");
2205 fp = fopen(cp,"w+","fop=dlt");
2213 * The C RTL's sigaction fails to check for invalid signal numbers so we
2214 * help it out a bit. The docs are correct, but the actual routine doesn't
2215 * do what the docs say it will.
2217 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2219 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2220 struct sigaction* oact)
2222 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2223 SETERRNO(EINVAL, SS$_INVARG);
2226 return sigaction(sig, act, oact);
2230 #ifdef KILL_BY_SIGPRC
2231 #include <errnodef.h>
2233 /* We implement our own kill() using the undocumented system service
2234 sys$sigprc for one of two reasons:
2236 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2237 target process to do a sys$exit, which usually can't be handled
2238 gracefully...certainly not by Perl and the %SIG{} mechanism.
2240 2.) If the kill() in the CRTL can't be called from a signal
2241 handler without disappearing into the ether, i.e., the signal
2242 it purportedly sends is never trapped. Still true as of VMS 7.3.
2244 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2245 in the target process rather than calling sys$exit.
2247 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2248 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2249 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2250 with condition codes C$_SIG0+nsig*8, catching the exception on the
2251 target process and resignaling with appropriate arguments.
2253 But we don't have that VMS 7.0+ exception handler, so if you
2254 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2256 Also note that SIGTERM is listed in the docs as being "unimplemented",
2257 yet always seems to be signaled with a VMS condition code of 4 (and
2258 correctly handled for that code). So we hardwire it in.
2260 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2261 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2262 than signalling with an unrecognized (and unhandled by CRTL) code.
2265 #define _MY_SIG_MAX 28
2268 Perl_sig_to_vmscondition_int(int sig)
2270 static unsigned int sig_code[_MY_SIG_MAX+1] =
2273 SS$_HANGUP, /* 1 SIGHUP */
2274 SS$_CONTROLC, /* 2 SIGINT */
2275 SS$_CONTROLY, /* 3 SIGQUIT */
2276 SS$_RADRMOD, /* 4 SIGILL */
2277 SS$_BREAK, /* 5 SIGTRAP */
2278 SS$_OPCCUS, /* 6 SIGABRT */
2279 SS$_COMPAT, /* 7 SIGEMT */
2281 SS$_FLTOVF, /* 8 SIGFPE VAX */
2283 SS$_HPARITH, /* 8 SIGFPE AXP */
2285 SS$_ABORT, /* 9 SIGKILL */
2286 SS$_ACCVIO, /* 10 SIGBUS */
2287 SS$_ACCVIO, /* 11 SIGSEGV */
2288 SS$_BADPARAM, /* 12 SIGSYS */
2289 SS$_NOMBX, /* 13 SIGPIPE */
2290 SS$_ASTFLT, /* 14 SIGALRM */
2307 static int initted = 0;
2310 sig_code[16] = C$_SIGUSR1;
2311 sig_code[17] = C$_SIGUSR2;
2312 sig_code[20] = C$_SIGCHLD;
2313 #if __CRTL_VER >= 70300000
2314 sig_code[28] = C$_SIGWINCH;
2318 if (sig < _SIG_MIN) return 0;
2319 if (sig > _MY_SIG_MAX) return 0;
2320 return sig_code[sig];
2324 Perl_sig_to_vmscondition(int sig)
2327 if (vms_debug_on_exception != 0)
2328 lib$signal(SS$_DEBUG);
2330 return Perl_sig_to_vmscondition_int(sig);
2334 #define sys$sigprc SYS$SIGPRC
2338 int sys$sigprc(unsigned int *pidadr,
2339 struct dsc$descriptor_s *prcname,
2346 Perl_my_kill(int pid, int sig)
2351 /* sig 0 means validate the PID */
2352 /*------------------------------*/
2354 const unsigned long int jpicode = JPI$_PID;
2357 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2358 if ($VMS_STATUS_SUCCESS(status))
2361 case SS$_NOSUCHNODE:
2362 case SS$_UNREACHABLE:
2376 code = Perl_sig_to_vmscondition_int(sig);
2379 SETERRNO(EINVAL, SS$_BADPARAM);
2383 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2384 * signals are to be sent to multiple processes.
2385 * pid = 0 - all processes in group except ones that the system exempts
2386 * pid = -1 - all processes except ones that the system exempts
2387 * pid = -n - all processes in group (abs(n)) except ...
2388 * For now, just report as not supported.
2392 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2396 iss = sys$sigprc((unsigned int *)&pid,0,code);
2397 if (iss&1) return 0;
2401 set_errno(EPERM); break;
2403 case SS$_NOSUCHNODE:
2404 case SS$_UNREACHABLE:
2405 set_errno(ESRCH); break;
2407 set_errno(ENOMEM); break;
2409 _ckvmssts_noperl(iss);
2412 set_vaxc_errno(iss);
2418 /* Routine to convert a VMS status code to a UNIX status code.
2419 ** More tricky than it appears because of conflicting conventions with
2422 ** VMS status codes are a bit mask, with the least significant bit set for
2425 ** Special UNIX status of EVMSERR indicates that no translation is currently
2426 ** available, and programs should check the VMS status code.
2428 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2432 #ifndef C_FACILITY_NO
2433 #define C_FACILITY_NO 0x350000
2436 #define DCL_IVVERB 0x38090
2439 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2447 /* Assume the best or the worst */
2448 if (vms_status & STS$M_SUCCESS)
2451 unix_status = EVMSERR;
2453 msg_status = vms_status & ~STS$M_CONTROL;
2455 facility = vms_status & STS$M_FAC_NO;
2456 fac_sp = vms_status & STS$M_FAC_SP;
2457 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2459 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2465 unix_status = EFAULT;
2467 case SS$_DEVOFFLINE:
2468 unix_status = EBUSY;
2471 unix_status = ENOTCONN;
2479 case SS$_INVFILFOROP:
2483 unix_status = EINVAL;
2485 case SS$_UNSUPPORTED:
2486 unix_status = ENOTSUP;
2491 unix_status = EACCES;
2493 case SS$_DEVICEFULL:
2494 unix_status = ENOSPC;
2497 unix_status = ENODEV;
2499 case SS$_NOSUCHFILE:
2500 case SS$_NOSUCHOBJECT:
2501 unix_status = ENOENT;
2503 case SS$_ABORT: /* Fatal case */
2504 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2505 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2506 unix_status = EINTR;
2509 unix_status = E2BIG;
2512 unix_status = ENOMEM;
2515 unix_status = EPERM;
2517 case SS$_NOSUCHNODE:
2518 case SS$_UNREACHABLE:
2519 unix_status = ESRCH;
2522 unix_status = ECHILD;
2525 if ((facility == 0) && (msg_no < 8)) {
2526 /* These are not real VMS status codes so assume that they are
2527 ** already UNIX status codes
2529 unix_status = msg_no;
2535 /* Translate a POSIX exit code to a UNIX exit code */
2536 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2537 unix_status = (msg_no & 0x07F8) >> 3;
2541 /* Documented traditional behavior for handling VMS child exits */
2542 /*--------------------------------------------------------------*/
2543 if (child_flag != 0) {
2545 /* Success / Informational return 0 */
2546 /*----------------------------------*/
2547 if (msg_no & STS$K_SUCCESS)
2550 /* Warning returns 1 */
2551 /*-------------------*/
2552 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2555 /* Everything else pass through the severity bits */
2556 /*------------------------------------------------*/
2557 return (msg_no & STS$M_SEVERITY);
2560 /* Normal VMS status to ERRNO mapping attempt */
2561 /*--------------------------------------------*/
2562 switch(msg_status) {
2563 /* case RMS$_EOF: */ /* End of File */
2564 case RMS$_FNF: /* File Not Found */
2565 case RMS$_DNF: /* Dir Not Found */
2566 unix_status = ENOENT;
2568 case RMS$_RNF: /* Record Not Found */
2569 unix_status = ESRCH;
2572 unix_status = ENOTDIR;
2575 unix_status = ENODEV;
2580 unix_status = EBADF;
2583 unix_status = EEXIST;
2587 case LIB$_INVSTRDES:
2589 case LIB$_NOSUCHSYM:
2590 case LIB$_INVSYMNAM:
2592 unix_status = EINVAL;
2598 unix_status = E2BIG;
2600 case RMS$_PRV: /* No privilege */
2601 case RMS$_ACC: /* ACP file access failed */
2602 case RMS$_WLK: /* Device write locked */
2603 unix_status = EACCES;
2605 case RMS$_MKD: /* Failed to mark for delete */
2606 unix_status = EPERM;
2608 /* case RMS$_NMF: */ /* No more files */
2616 /* Try to guess at what VMS error status should go with a UNIX errno
2617 * value. This is hard to do as there could be many possible VMS
2618 * error statuses that caused the errno value to be set.
2621 int Perl_unix_status_to_vms(int unix_status)
2623 int test_unix_status;
2625 /* Trivial cases first */
2626 /*---------------------*/
2627 if (unix_status == EVMSERR)
2630 /* Is vaxc$errno sane? */
2631 /*---------------------*/
2632 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2633 if (test_unix_status == unix_status)
2636 /* If way out of range, must be VMS code already */
2637 /*-----------------------------------------------*/
2638 if (unix_status > EVMSERR)
2641 /* If out of range, punt */
2642 /*-----------------------*/
2643 if (unix_status > __ERRNO_MAX)
2647 /* Ok, now we have to do it the hard way. */
2648 /*----------------------------------------*/
2649 switch(unix_status) {
2650 case 0: return SS$_NORMAL;
2651 case EPERM: return SS$_NOPRIV;
2652 case ENOENT: return SS$_NOSUCHOBJECT;
2653 case ESRCH: return SS$_UNREACHABLE;
2654 case EINTR: return SS$_ABORT;
2657 case E2BIG: return SS$_BUFFEROVF;
2659 case EBADF: return RMS$_IFI;
2660 case ECHILD: return SS$_NONEXPR;
2662 case ENOMEM: return SS$_INSFMEM;
2663 case EACCES: return SS$_FILACCERR;
2664 case EFAULT: return SS$_ACCVIO;
2666 case EBUSY: return SS$_DEVOFFLINE;
2667 case EEXIST: return RMS$_FEX;
2669 case ENODEV: return SS$_NOSUCHDEV;
2670 case ENOTDIR: return RMS$_DIR;
2672 case EINVAL: return SS$_INVARG;
2678 case ENOSPC: return SS$_DEVICEFULL;
2679 case ESPIPE: return LIB$_INVARG;
2684 case ERANGE: return LIB$_INVARG;
2685 /* case EWOULDBLOCK */
2686 /* case EINPROGRESS */
2689 /* case EDESTADDRREQ */
2691 /* case EPROTOTYPE */
2692 /* case ENOPROTOOPT */
2693 /* case EPROTONOSUPPORT */
2694 /* case ESOCKTNOSUPPORT */
2695 /* case EOPNOTSUPP */
2696 /* case EPFNOSUPPORT */
2697 /* case EAFNOSUPPORT */
2698 /* case EADDRINUSE */
2699 /* case EADDRNOTAVAIL */
2701 /* case ENETUNREACH */
2702 /* case ENETRESET */
2703 /* case ECONNABORTED */
2704 /* case ECONNRESET */
2707 case ENOTCONN: return SS$_CLEARED;
2708 /* case ESHUTDOWN */
2709 /* case ETOOMANYREFS */
2710 /* case ETIMEDOUT */
2711 /* case ECONNREFUSED */
2713 /* case ENAMETOOLONG */
2714 /* case EHOSTDOWN */
2715 /* case EHOSTUNREACH */
2716 /* case ENOTEMPTY */
2728 /* case ECANCELED */
2732 return SS$_UNSUPPORTED;
2738 /* case EABANDONED */
2740 return SS$_ABORT; /* punt */
2745 /* default piping mailbox size */
2747 # define PERL_BUFSIZ 512
2749 # define PERL_BUFSIZ 8192
2754 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2756 unsigned long int mbxbufsiz;
2757 static unsigned long int syssize = 0;
2758 unsigned long int dviitm = DVI$_DEVNAM;
2759 char csize[LNM$C_NAMLENGTH+1];
2763 unsigned long syiitm = SYI$_MAXBUF;
2765 * Get the SYSGEN parameter MAXBUF
2767 * If the logical 'PERL_MBX_SIZE' is defined
2768 * use the value of the logical instead of PERL_BUFSIZ, but
2769 * keep the size between 128 and MAXBUF.
2772 _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2775 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2776 mbxbufsiz = atoi(csize);
2778 mbxbufsiz = PERL_BUFSIZ;
2780 if (mbxbufsiz < 128) mbxbufsiz = 128;
2781 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2783 _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2785 sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2786 _ckvmssts_noperl(sts);
2787 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2789 } /* end of create_mbx() */
2792 /*{{{ my_popen and my_pclose*/
2794 typedef struct _iosb IOSB;
2795 typedef struct _iosb* pIOSB;
2796 typedef struct _pipe Pipe;
2797 typedef struct _pipe* pPipe;
2798 typedef struct pipe_details Info;
2799 typedef struct pipe_details* pInfo;
2800 typedef struct _srqp RQE;
2801 typedef struct _srqp* pRQE;
2802 typedef struct _tochildbuf CBuf;
2803 typedef struct _tochildbuf* pCBuf;
2806 unsigned short status;
2807 unsigned short count;
2808 unsigned long dvispec;
2811 #pragma member_alignment save
2812 #pragma nomember_alignment quadword
2813 struct _srqp { /* VMS self-relative queue entry */
2814 unsigned long qptr[2];
2816 #pragma member_alignment restore
2817 static RQE RQE_ZERO = {0,0};
2819 struct _tochildbuf {
2822 unsigned short size;
2830 unsigned short chan_in;
2831 unsigned short chan_out;
2833 unsigned int bufsize;
2845 #if defined(PERL_IMPLICIT_CONTEXT)
2846 void *thx; /* Either a thread or an interpreter */
2847 /* pointer, depending on how we're built */
2855 PerlIO *fp; /* file pointer to pipe mailbox */
2856 int useFILE; /* using stdio, not perlio */
2857 int pid; /* PID of subprocess */
2858 int mode; /* == 'r' if pipe open for reading */
2859 int done; /* subprocess has completed */
2860 int waiting; /* waiting for completion/closure */
2861 int closing; /* my_pclose is closing this pipe */
2862 unsigned long completion; /* termination status of subprocess */
2863 pPipe in; /* pipe in to sub */
2864 pPipe out; /* pipe out of sub */
2865 pPipe err; /* pipe of sub's sys$error */
2866 int in_done; /* true when in pipe finished */
2869 unsigned short xchan; /* channel to debug xterm */
2870 unsigned short xchan_valid; /* channel is assigned */
2873 struct exit_control_block
2875 struct exit_control_block *flink;
2876 unsigned long int (*exit_routine)(void);
2877 unsigned long int arg_count;
2878 unsigned long int *status_address;
2879 unsigned long int exit_status;
2882 typedef struct _closed_pipes Xpipe;
2883 typedef struct _closed_pipes* pXpipe;
2885 struct _closed_pipes {
2886 int pid; /* PID of subprocess */
2887 unsigned long completion; /* termination status of subprocess */
2889 #define NKEEPCLOSED 50
2890 static Xpipe closed_list[NKEEPCLOSED];
2891 static int closed_index = 0;
2892 static int closed_num = 0;
2894 #define RETRY_DELAY "0 ::0.20"
2895 #define MAX_RETRY 50
2897 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2898 static unsigned long mypid;
2899 static unsigned long delaytime[2];
2901 static pInfo open_pipes = NULL;
2902 static $DESCRIPTOR(nl_desc, "NL:");
2904 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2908 static unsigned long int
2909 pipe_exit_routine(void)
2912 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2913 int sts, did_stuff, j;
2916 * Flush any pending i/o, but since we are in process run-down, be
2917 * careful about referencing PerlIO structures that may already have
2918 * been deallocated. We may not even have an interpreter anymore.
2923 #if defined(PERL_IMPLICIT_CONTEXT)
2924 /* We need to use the Perl context of the thread that created */
2928 aTHX = info->err->thx;
2930 aTHX = info->out->thx;
2932 aTHX = info->in->thx;
2935 #if defined(USE_ITHREADS)
2939 && PL_perlio_fd_refcnt
2942 PerlIO_flush(info->fp);
2944 fflush((FILE *)info->fp);
2950 next we try sending an EOF...ignore if doesn't work, make sure we
2957 _ckvmssts_noperl(sys$setast(0));
2958 if (info->in && !info->in->shut_on_empty) {
2959 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2964 _ckvmssts_noperl(sys$setast(1));
2968 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2970 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2975 _ckvmssts_noperl(sys$setast(0));
2976 if (info->waiting && info->done)
2978 nwait += info->waiting;
2979 _ckvmssts_noperl(sys$setast(1));
2989 _ckvmssts_noperl(sys$setast(0));
2990 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2991 sts = sys$forcex(&info->pid,0,&abort);
2992 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2995 _ckvmssts_noperl(sys$setast(1));
2999 /* again, wait for effect */
3001 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3006 _ckvmssts_noperl(sys$setast(0));
3007 if (info->waiting && info->done)
3009 nwait += info->waiting;
3010 _ckvmssts_noperl(sys$setast(1));
3019 _ckvmssts_noperl(sys$setast(0));
3020 if (!info->done) { /* We tried to be nice . . . */
3021 sts = sys$delprc(&info->pid,0);
3022 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3023 info->done = 1; /* sys$delprc is as done as we're going to get. */
3025 _ckvmssts_noperl(sys$setast(1));
3031 #if defined(PERL_IMPLICIT_CONTEXT)
3032 /* We need to use the Perl context of the thread that created */
3035 if (open_pipes->err)
3036 aTHX = open_pipes->err->thx;
3037 else if (open_pipes->out)
3038 aTHX = open_pipes->out->thx;
3039 else if (open_pipes->in)
3040 aTHX = open_pipes->in->thx;
3042 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3043 else if (!(sts & 1)) retsts = sts;
3048 static struct exit_control_block pipe_exitblock =
3049 {(struct exit_control_block *) 0,
3050 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3052 static void pipe_mbxtofd_ast(pPipe p);
3053 static void pipe_tochild1_ast(pPipe p);
3054 static void pipe_tochild2_ast(pPipe p);
3057 popen_completion_ast(pInfo info)
3059 pInfo i = open_pipes;
3062 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3063 closed_list[closed_index].pid = info->pid;
3064 closed_list[closed_index].completion = info->completion;
3066 if (closed_index == NKEEPCLOSED)
3071 if (i == info) break;
3074 if (!i) return; /* unlinked, probably freed too */
3079 Writing to subprocess ...
3080 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3082 chan_out may be waiting for "done" flag, or hung waiting
3083 for i/o completion to child...cancel the i/o. This will
3084 put it into "snarf mode" (done but no EOF yet) that discards
3087 Output from subprocess (stdout, stderr) needs to be flushed and
3088 shut down. We try sending an EOF, but if the mbx is full the pipe
3089 routine should still catch the "shut_on_empty" flag, telling it to
3090 use immediate-style reads so that "mbx empty" -> EOF.
3094 if (info->in && !info->in_done) { /* only for mode=w */
3095 if (info->in->shut_on_empty && info->in->need_wake) {
3096 info->in->need_wake = FALSE;
3097 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3099 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3103 if (info->out && !info->out_done) { /* were we also piping output? */
3104 info->out->shut_on_empty = TRUE;
3105 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3106 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3107 _ckvmssts_noperl(iss);
3110 if (info->err && !info->err_done) { /* we were piping stderr */
3111 info->err->shut_on_empty = TRUE;
3112 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3113 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3114 _ckvmssts_noperl(iss);
3116 _ckvmssts_noperl(sys$setef(pipe_ef));
3120 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3121 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3122 static void pipe_infromchild_ast(pPipe p);
3125 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3126 inside an AST routine without worrying about reentrancy and which Perl
3127 memory allocator is being used.
3129 We read data and queue up the buffers, then spit them out one at a
3130 time to the output mailbox when the output mailbox is ready for one.
3133 #define INITIAL_TOCHILDQUEUE 2
3136 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3140 char mbx1[64], mbx2[64];
3141 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3142 DSC$K_CLASS_S, mbx1},
3143 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3144 DSC$K_CLASS_S, mbx2};
3145 unsigned int dviitm = DVI$_DEVBUFSIZ;
3149 _ckvmssts_noperl(lib$get_vm(&n, &p));
3151 create_mbx(&p->chan_in , &d_mbx1);
3152 create_mbx(&p->chan_out, &d_mbx2);
3153 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3156 p->shut_on_empty = FALSE;
3157 p->need_wake = FALSE;
3160 p->iosb.status = SS$_NORMAL;
3161 p->iosb2.status = SS$_NORMAL;
3167 #ifdef PERL_IMPLICIT_CONTEXT
3171 n = sizeof(CBuf) + p->bufsize;
3173 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3174 _ckvmssts_noperl(lib$get_vm(&n, &b));
3175 b->buf = (char *) b + sizeof(CBuf);
3176 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3179 pipe_tochild2_ast(p);
3180 pipe_tochild1_ast(p);
3186 /* reads the MBX Perl is writing, and queues */
3189 pipe_tochild1_ast(pPipe p)
3192 int iss = p->iosb.status;
3193 int eof = (iss == SS$_ENDOFFILE);
3195 #ifdef PERL_IMPLICIT_CONTEXT
3201 p->shut_on_empty = TRUE;
3203 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3205 _ckvmssts_noperl(iss);
3209 b->size = p->iosb.count;
3210 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3212 p->need_wake = FALSE;
3213 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3216 p->retry = 1; /* initial call */
3219 if (eof) { /* flush the free queue, return when done */
3220 int n = sizeof(CBuf) + p->bufsize;
3222 iss = lib$remqti(&p->free, &b);
3223 if (iss == LIB$_QUEWASEMP) return;
3224 _ckvmssts_noperl(iss);
3225 _ckvmssts_noperl(lib$free_vm(&n, &b));
3229 iss = lib$remqti(&p->free, &b);
3230 if (iss == LIB$_QUEWASEMP) {
3231 int n = sizeof(CBuf) + p->bufsize;
3232 _ckvmssts_noperl(lib$get_vm(&n, &b));
3233 b->buf = (char *) b + sizeof(CBuf);
3235 _ckvmssts_noperl(iss);
3239 iss = sys$qio(0,p->chan_in,
3240 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3242 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3243 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3244 _ckvmssts_noperl(iss);
3248 /* writes queued buffers to output, waits for each to complete before
3252 pipe_tochild2_ast(pPipe p)
3255 int iss = p->iosb2.status;
3256 int n = sizeof(CBuf) + p->bufsize;
3257 int done = (p->info && p->info->done) ||
3258 iss == SS$_CANCEL || iss == SS$_ABORT;
3259 #if defined(PERL_IMPLICIT_CONTEXT)
3264 if (p->type) { /* type=1 has old buffer, dispose */
3265 if (p->shut_on_empty) {
3266 _ckvmssts_noperl(lib$free_vm(&n, &b));
3268 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3273 iss = lib$remqti(&p->wait, &b);
3274 if (iss == LIB$_QUEWASEMP) {
3275 if (p->shut_on_empty) {
3277 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3278 *p->pipe_done = TRUE;
3279 _ckvmssts_noperl(sys$setef(pipe_ef));
3281 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3282 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3286 p->need_wake = TRUE;
3289 _ckvmssts_noperl(iss);
3296 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3297 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3299 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3300 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3309 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3312 char mbx1[64], mbx2[64];
3313 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3314 DSC$K_CLASS_S, mbx1},
3315 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3316 DSC$K_CLASS_S, mbx2};
3317 unsigned int dviitm = DVI$_DEVBUFSIZ;
3319 int n = sizeof(Pipe);
3320 _ckvmssts_noperl(lib$get_vm(&n, &p));
3321 create_mbx(&p->chan_in , &d_mbx1);
3322 create_mbx(&p->chan_out, &d_mbx2);
3324 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3325 n = p->bufsize * sizeof(char);
3326 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3327 p->shut_on_empty = FALSE;
3330 p->iosb.status = SS$_NORMAL;
3331 #if defined(PERL_IMPLICIT_CONTEXT)
3334 pipe_infromchild_ast(p);
3342 pipe_infromchild_ast(pPipe p)
3344 int iss = p->iosb.status;
3345 int eof = (iss == SS$_ENDOFFILE);
3346 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3347 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3348 #if defined(PERL_IMPLICIT_CONTEXT)
3352 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3353 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3358 input shutdown if EOF from self (done or shut_on_empty)
3359 output shutdown if closing flag set (my_pclose)
3360 send data/eof from child or eof from self
3361 otherwise, re-read (snarf of data from child)
3366 if (myeof && p->chan_in) { /* input shutdown */
3367 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3372 if (myeof || kideof) { /* pass EOF to parent */
3373 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3374 pipe_infromchild_ast, p,
3377 } else if (eof) { /* eat EOF --- fall through to read*/
3379 } else { /* transmit data */
3380 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3381 pipe_infromchild_ast,p,
3382 p->buf, p->iosb.count, 0, 0, 0, 0));
3388 /* everything shut? flag as done */
3390 if (!p->chan_in && !p->chan_out) {
3391 *p->pipe_done = TRUE;
3392 _ckvmssts_noperl(sys$setef(pipe_ef));
3396 /* write completed (or read, if snarfing from child)
3397 if still have input active,
3398 queue read...immediate mode if shut_on_empty so we get EOF if empty
3400 check if Perl reading, generate EOFs as needed
3406 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3407 pipe_infromchild_ast,p,
3408 p->buf, p->bufsize, 0, 0, 0, 0);
3409 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3410 _ckvmssts_noperl(iss);
3411 } else { /* send EOFs for extra reads */
3412 p->iosb.status = SS$_ENDOFFILE;
3413 p->iosb.dvispec = 0;
3414 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3416 pipe_infromchild_ast, p, 0, 0, 0, 0));
3422 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3426 unsigned long dviitm = DVI$_DEVBUFSIZ;
3428 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3429 DSC$K_CLASS_S, mbx};
3430 int n = sizeof(Pipe);
3432 /* things like terminals and mbx's don't need this filter */
3433 if (fd && fstat(fd,&s) == 0) {
3434 unsigned long devchar;
3436 unsigned short dev_len;
3437 struct dsc$descriptor_s d_dev;
3439 struct item_list_3 items[3];
3441 unsigned short dvi_iosb[4];
3443 cptr = getname(fd, out, 1);
3444 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3445 d_dev.dsc$a_pointer = out;
3446 d_dev.dsc$w_length = strlen(out);
3447 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3448 d_dev.dsc$b_class = DSC$K_CLASS_S;
3451 items[0].code = DVI$_DEVCHAR;
3452 items[0].bufadr = &devchar;
3453 items[0].retadr = NULL;
3455 items[1].code = DVI$_FULLDEVNAM;
3456 items[1].bufadr = device;
3457 items[1].retadr = &dev_len;
3461 status = sys$getdviw
3462 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3463 _ckvmssts_noperl(status);
3464 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3465 device[dev_len] = 0;
3467 if (!(devchar & DEV$M_DIR)) {
3468 strcpy(out, device);
3474 _ckvmssts_noperl(lib$get_vm(&n, &p));
3475 p->fd_out = dup(fd);
3476 create_mbx(&p->chan_in, &d_mbx);
3477 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3478 n = (p->bufsize+1) * sizeof(char);
3479 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3480 p->shut_on_empty = FALSE;
3485 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3486 pipe_mbxtofd_ast, p,
3487 p->buf, p->bufsize, 0, 0, 0, 0));
3493 pipe_mbxtofd_ast(pPipe p)
3495 int iss = p->iosb.status;
3496 int done = p->info->done;
3498 int eof = (iss == SS$_ENDOFFILE);
3499 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3500 int err = !(iss&1) && !eof;
3501 #if defined(PERL_IMPLICIT_CONTEXT)
3505 if (done && myeof) { /* end piping */
3507 sys$dassgn(p->chan_in);
3508 *p->pipe_done = TRUE;
3509 _ckvmssts_noperl(sys$setef(pipe_ef));
3513 if (!err && !eof) { /* good data to send to file */
3514 p->buf[p->iosb.count] = '\n';
3515 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3518 if (p->retry < MAX_RETRY) {
3519 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3525 _ckvmssts_noperl(iss);
3529 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3530 pipe_mbxtofd_ast, p,
3531 p->buf, p->bufsize, 0, 0, 0, 0);
3532 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3533 _ckvmssts_noperl(iss);
3537 typedef struct _pipeloc PLOC;
3538 typedef struct _pipeloc* pPLOC;
3542 char dir[NAM$C_MAXRSS+1];
3544 static pPLOC head_PLOC = 0;
3547 free_pipelocs(pTHX_ void *head)
3550 pPLOC *pHead = (pPLOC *)head;
3562 store_pipelocs(pTHX)
3570 char temp[NAM$C_MAXRSS+1];
3574 free_pipelocs(aTHX_ &head_PLOC);
3576 /* the . directory from @INC comes last */
3578 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3579 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3580 p->next = head_PLOC;
3582 strcpy(p->dir,"./");
3584 /* get the directory from $^X */
3586 unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3587 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3589 #ifdef PERL_IMPLICIT_CONTEXT
3590 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3592 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3594 my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3595 x = strrchr(temp,']');
3597 x = strrchr(temp,'>');
3599 /* It could be a UNIX path */
3600 x = strrchr(temp,'/');
3606 /* Got a bare name, so use default directory */
3611 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3612 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3613 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3614 p->next = head_PLOC;
3616 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3620 /* reverse order of @INC entries, skip "." since entered above */
3622 #ifdef PERL_IMPLICIT_CONTEXT
3625 if (PL_incgv) av = GvAVn(PL_incgv);
3627 for (i = 0; av && i <= AvFILL(av); i++) {
3628 dirsv = *av_fetch(av,i,TRUE);
3630 if (SvROK(dirsv)) continue;
3631 dir = SvPVx(dirsv,n_a);
3632 if (strcmp(dir,".") == 0) continue;
3633 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3636 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3637 p->next = head_PLOC;
3639 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3642 /* most likely spot (ARCHLIB) put first in the list */
3645 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3646 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3647 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3648 p->next = head_PLOC;
3650 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3653 PerlMem_free(unixdir);
3657 Perl_cando_by_name_int
3658 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3659 #if !defined(PERL_IMPLICIT_CONTEXT)
3660 #define cando_by_name_int Perl_cando_by_name_int
3662 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3668 static int vmspipe_file_status = 0;
3669 static char vmspipe_file[NAM$C_MAXRSS+1];
3671 /* already found? Check and use ... need read+execute permission */
3673 if (vmspipe_file_status == 1) {
3674 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3675 && cando_by_name_int
3676 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3677 return vmspipe_file;
3679 vmspipe_file_status = 0;
3682 /* scan through stored @INC, $^X */
3684 if (vmspipe_file_status == 0) {
3685 char file[NAM$C_MAXRSS+1];
3686 pPLOC p = head_PLOC;
3691 dirlen = my_strlcpy(file, p->dir, sizeof(file));
3692 my_strlcat(file, "vmspipe.com", sizeof(file));
3695 exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3696 if (!exp_res) continue;
3698 if (cando_by_name_int
3699 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3700 && cando_by_name_int
3701 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3702 vmspipe_file_status = 1;
3703 return vmspipe_file;
3706 vmspipe_file_status = -1; /* failed, use tempfiles */
3713 vmspipe_tempfile(pTHX)
3715 char file[NAM$C_MAXRSS+1];
3717 static int index = 0;
3721 /* create a tempfile */
3723 /* we can't go from W, shr=get to R, shr=get without
3724 an intermediate vulnerable state, so don't bother trying...
3726 and lib$spawn doesn't shr=put, so have to close the write
3728 So... match up the creation date/time and the FID to
3729 make sure we're dealing with the same file
3734 if (!decc_filename_unix_only) {
3735 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3736 fp = fopen(file,"w");
3738 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3739 fp = fopen(file,"w");
3741 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3742 fp = fopen(file,"w");
3747 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3748 fp = fopen(file,"w");
3750 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3751 fp = fopen(file,"w");
3753 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3754 fp = fopen(file,"w");
3758 if (!fp) return 0; /* we're hosed */
3760 fprintf(fp,"$! 'f$verify(0)'\n");
3761 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3762 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3763 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3764 fprintf(fp,"$ perl_on = \"set noon\"\n");
3765 fprintf(fp,"$ perl_exit = \"exit\"\n");
3766 fprintf(fp,"$ perl_del = \"delete\"\n");
3767 fprintf(fp,"$ pif = \"if\"\n");
3768 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3769 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3770 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3771 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3772 fprintf(fp,"$! --- build command line to get max possible length\n");
3773 fprintf(fp,"$c=perl_popen_cmd0\n");
3774 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3775 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3776 fprintf(fp,"$x=perl_popen_cmd3\n");
3777 fprintf(fp,"$c=c+x\n");
3778 fprintf(fp,"$ perl_on\n");
3779 fprintf(fp,"$ 'c'\n");
3780 fprintf(fp,"$ perl_status = $STATUS\n");
3781 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3782 fprintf(fp,"$ perl_exit 'perl_status'\n");
3785 fgetname(fp, file, 1);
3786 fstat(fileno(fp), &s0.crtl_stat);
3789 if (decc_filename_unix_only)
3790 int_tounixspec(file, file, NULL);
3791 fp = fopen(file,"r","shr=get");
3793 fstat(fileno(fp), &s1.crtl_stat);
3795 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3796 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3805 static int vms_is_syscommand_xterm(void)
3807 const static struct dsc$descriptor_s syscommand_dsc =
3808 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3810 const static struct dsc$descriptor_s decwdisplay_dsc =
3811 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3813 struct item_list_3 items[2];
3814 unsigned short dvi_iosb[4];
3815 unsigned long devchar;
3816 unsigned long devclass;
3819 /* Very simple check to guess if sys$command is a decterm? */
3820 /* First see if the DECW$DISPLAY: device exists */
3822 items[0].code = DVI$_DEVCHAR;
3823 items[0].bufadr = &devchar;
3824 items[0].retadr = NULL;
3828 status = sys$getdviw
3829 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3831 if ($VMS_STATUS_SUCCESS(status)) {
3832 status = dvi_iosb[0];
3835 if (!$VMS_STATUS_SUCCESS(status)) {
3836 SETERRNO(EVMSERR, status);
3840 /* If it does, then for now assume that we are on a workstation */
3841 /* Now verify that SYS$COMMAND is a terminal */
3842 /* for creating the debugger DECTerm */
3845 items[0].code = DVI$_DEVCLASS;
3846 items[0].bufadr = &devclass;
3847 items[0].retadr = NULL;
3851 status = sys$getdviw
3852 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3854 if ($VMS_STATUS_SUCCESS(status)) {
3855 status = dvi_iosb[0];
3858 if (!$VMS_STATUS_SUCCESS(status)) {
3859 SETERRNO(EVMSERR, status);
3863 if (devclass == DC$_TERM) {
3870 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3871 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3876 char device_name[65];
3877 unsigned short device_name_len;
3878 struct dsc$descriptor_s customization_dsc;
3879 struct dsc$descriptor_s device_name_dsc;
3881 char customization[200];
3885 unsigned short p_chan;
3887 unsigned short iosb[4];
3888 const char * cust_str =
3889 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3890 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3891 DSC$K_CLASS_S, mbx1};
3893 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3894 /*---------------------------------------*/
3895 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3898 /* Make sure that this is from the Perl debugger */
3899 ret_char = strstr(cmd," xterm ");
3900 if (ret_char == NULL)
3902 cptr = ret_char + 7;
3903 ret_char = strstr(cmd,"tty");
3904 if (ret_char == NULL)
3906 ret_char = strstr(cmd,"sleep");
3907 if (ret_char == NULL)
3910 if (decw_term_port == 0) {
3911 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3912 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3913 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3915 status = lib$find_image_symbol
3917 &decw_term_port_dsc,
3918 (void *)&decw_term_port,
3922 /* Try again with the other image name */
3923 if (!$VMS_STATUS_SUCCESS(status)) {
3925 status = lib$find_image_symbol
3927 &decw_term_port_dsc,
3928 (void *)&decw_term_port,
3937 /* No decw$term_port, give it up */
3938 if (!$VMS_STATUS_SUCCESS(status))
3941 /* Are we on a workstation? */
3942 /* to do: capture the rows / columns and pass their properties */
3943 ret_stat = vms_is_syscommand_xterm();
3947 /* Make the title: */
3948 ret_char = strstr(cptr,"-title");
3949 if (ret_char != NULL) {
3950 while ((*cptr != 0) && (*cptr != '\"')) {
3956 while ((*cptr != 0) && (*cptr != '\"')) {
3969 strcpy(title,"Perl Debug DECTerm");
3971 sprintf(customization, cust_str, title);
3973 customization_dsc.dsc$a_pointer = customization;
3974 customization_dsc.dsc$w_length = strlen(customization);
3975 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3976 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3978 device_name_dsc.dsc$a_pointer = device_name;
3979 device_name_dsc.dsc$w_length = sizeof device_name -1;
3980 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3981 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3983 device_name_len = 0;
3985 /* Try to create the window */
3986 status = (*decw_term_port)
3995 if (!$VMS_STATUS_SUCCESS(status)) {
3996 SETERRNO(EVMSERR, status);
4000 device_name[device_name_len] = '\0';
4002 /* Need to set this up to look like a pipe for cleanup */
4004 status = lib$get_vm(&n, &info);
4005 if (!$VMS_STATUS_SUCCESS(status)) {
4006 SETERRNO(ENOMEM, status);
4012 info->completion = 0;
4013 info->closing = FALSE;
4020 info->in_done = TRUE;
4021 info->out_done = TRUE;
4022 info->err_done = TRUE;
4024 /* Assign a channel on this so that it will persist, and not login */
4025 /* We stash this channel in the info structure for reference. */
4026 /* The created xterm self destructs when the last channel is removed */
4027 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4028 /* So leave this assigned. */
4029 device_name_dsc.dsc$w_length = device_name_len;
4030 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4031 if (!$VMS_STATUS_SUCCESS(status)) {
4032 SETERRNO(EVMSERR, status);
4035 info->xchan_valid = 1;
4037 /* Now create a mailbox to be read by the application */
4039 create_mbx(&p_chan, &d_mbx1);
4041 /* write the name of the created terminal to the mailbox */
4042 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4043 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4045 if (!$VMS_STATUS_SUCCESS(status)) {
4046 SETERRNO(EVMSERR, status);
4050 info->fp = PerlIO_open(mbx1, mode);
4052 /* Done with this channel */
4055 /* If any errors, then clean up */
4058 _ckvmssts_noperl(lib$free_vm(&n, &info));
4066 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4069 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4071 static int handler_set_up = FALSE;
4073 unsigned long int sts, flags = CLI$M_NOWAIT;
4074 /* The use of a GLOBAL table (as was done previously) rendered
4075 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4076 * environment. Hence we've switched to LOCAL symbol table.
4078 unsigned int table = LIB$K_CLI_LOCAL_SYM;
4080 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4081 char *in, *out, *err, mbx[512];
4083 char tfilebuf[NAM$C_MAXRSS+1];
4085 char cmd_sym_name[20];
4086 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4087 DSC$K_CLASS_S, symbol};
4088 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4090 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4091 DSC$K_CLASS_S, cmd_sym_name};
4092 struct dsc$descriptor_s *vmscmd;
4093 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4094 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4095 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4097 /* Check here for Xterm create request. This means looking for
4098 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4099 * is possible to create an xterm.
4101 if (*in_mode == 'r') {
4104 #if defined(PERL_IMPLICIT_CONTEXT)
4105 /* Can not fork an xterm with a NULL context */
4106 /* This probably could never happen */
4110 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4111 if (xterm_fd != NULL)
4115 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4117 /* once-per-program initialization...
4118 note that the SETAST calls and the dual test of pipe_ef
4119 makes sure that only the FIRST thread through here does
4120 the initialization...all other threads wait until it's
4123 Yeah, uglier than a pthread call, it's got all the stuff inline
4124 rather than in a separate routine.
4128 _ckvmssts_noperl(sys$setast(0));
4130 unsigned long int pidcode = JPI$_PID;
4131 $DESCRIPTOR(d_delay, RETRY_DELAY);
4132 _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4133 _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4134 _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4136 if (!handler_set_up) {
4137 _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4138 handler_set_up = TRUE;
4140 _ckvmssts_noperl(sys$setast(1));
4143 /* see if we can find a VMSPIPE.COM */
4146 vmspipe = find_vmspipe(aTHX);
4148 vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4149 } else { /* uh, oh...we're in tempfile hell */
4150 tpipe = vmspipe_tempfile(aTHX);
4151 if (!tpipe) { /* a fish popular in Boston */
4152 if (ckWARN(WARN_PIPE)) {
4153 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4157 fgetname(tpipe,tfilebuf+1,1);
4158 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4160 vmspipedsc.dsc$a_pointer = tfilebuf;
4162 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4165 case RMS$_FNF: case RMS$_DNF:
4166 set_errno(ENOENT); break;
4168 set_errno(ENOTDIR); break;
4170 set_errno(ENODEV); break;
4172 set_errno(EACCES); break;
4174 set_errno(EINVAL); break;
4175 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4176 set_errno(E2BIG); break;
4177 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4178 _ckvmssts_noperl(sts); /* fall through */
4179 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4182 set_vaxc_errno(sts);
4183 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4184 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4190 _ckvmssts_noperl(lib$get_vm(&n, &info));
4192 my_strlcpy(mode, in_mode, sizeof(mode));
4195 info->completion = 0;
4196 info->closing = FALSE;
4203 info->in_done = TRUE;
4204 info->out_done = TRUE;
4205 info->err_done = TRUE;
4207 info->xchan_valid = 0;
4209 in = (char *)PerlMem_malloc(VMS_MAXRSS);
4210 if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4211 out = (char *)PerlMem_malloc(VMS_MAXRSS);
4212 if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4213 err = (char *)PerlMem_malloc(VMS_MAXRSS);
4214 if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4216 in[0] = out[0] = err[0] = '\0';
4218 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4222 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4227 if (*mode == 'r') { /* piping from subroutine */
4229 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4231 info->out->pipe_done = &info->out_done;
4232 info->out_done = FALSE;
4233 info->out->info = info;
4235 if (!info->useFILE) {
4236 info->fp = PerlIO_open(mbx, mode);
4238 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4239 vmssetuserlnm("SYS$INPUT", mbx);
4242 if (!info->fp && info->out) {
4243 sys$cancel(info->out->chan_out);
4245 while (!info->out_done) {
4247 _ckvmssts_noperl(sys$setast(0));
4248 done = info->out_done;
4249 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4250 _ckvmssts_noperl(sys$setast(1));
4251 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4254 if (info->out->buf) {
4255 n = info->out->bufsize * sizeof(char);
4256 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4259 _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4261 _ckvmssts_noperl(lib$free_vm(&n, &info));
4266 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4268 info->err->pipe_done = &info->err_done;
4269 info->err_done = FALSE;
4270 info->err->info = info;
4273 } else if (*mode == 'w') { /* piping to subroutine */
4275 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4277 info->out->pipe_done = &info->out_done;
4278 info->out_done = FALSE;
4279 info->out->info = info;
4282 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4284 info->err->pipe_done = &info->err_done;
4285 info->err_done = FALSE;
4286 info->err->info = info;
4289 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4290 if (!info->useFILE) {
4291 info->fp = PerlIO_open(mbx, mode);
4293 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4294 vmssetuserlnm("SYS$OUTPUT", mbx);
4298 info->in->pipe_done = &info->in_done;
4299 info->in_done = FALSE;
4300 info->in->info = info;
4304 if (!info->fp && info->in) {
4306 _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4307 0, 0, 0, 0, 0, 0, 0, 0));
4309 while (!info->in_done) {
4311 _ckvmssts_noperl(sys$setast(0));
4312 done = info->in_done;
4313 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4314 _ckvmssts_noperl(sys$setast(1));
4315 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4318 if (info->in->buf) {
4319 n = info->in->bufsize * sizeof(char);
4320 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4323 _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4325 _ckvmssts_noperl(lib$free_vm(&n, &info));
4331 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4332 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4334 info->out->pipe_done = &info->out_done;
4335 info->out_done = FALSE;
4336 info->out->info = info;
4339 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4341 info->err->pipe_done = &info->err_done;
4342 info->err_done = FALSE;
4343 info->err->info = info;
4347 d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4348 _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4350 d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4351 _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4353 d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4354 _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4356 /* Done with the names for the pipes */
4361 p = vmscmd->dsc$a_pointer;
4362 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4363 if (*p == '$') p++; /* remove leading $ */
4364 while (*p == ' ' || *p == '\t') p++;
4366 for (j = 0; j < 4; j++) {
4367 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4368 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4370 d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4371 _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4373 if (strlen(p) > MAX_DCL_SYMBOL) {
4374 p += MAX_DCL_SYMBOL;
4379 _ckvmssts_noperl(sys$setast(0));
4380 info->next=open_pipes; /* prepend to list */
4382 _ckvmssts_noperl(sys$setast(1));
4383 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4384 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4385 * have SYS$COMMAND if we need it.
4387 _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4388 0, &info->pid, &info->completion,
4389 0, popen_completion_ast,info,0,0,0));
4391 /* if we were using a tempfile, close it now */
4393 if (tpipe) fclose(tpipe);
4395 /* once the subprocess is spawned, it has copied the symbols and
4396 we can get rid of ours */
4398 for (j = 0; j < 4; j++) {
4399 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4400 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4401 _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4403 _ckvmssts_noperl(lib$delete_symbol(&d_sym_in, &table));
4404 _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4405 _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4406 vms_execfree(vmscmd);
4408 #ifdef PERL_IMPLICIT_CONTEXT
4411 PL_forkprocess = info->pid;
4418 _ckvmssts_noperl(sys$setast(0));
4420 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4421 _ckvmssts_noperl(sys$setast(1));
4422 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4424 *psts = info->completion;
4425 /* Caller thinks it is open and tries to close it. */
4426 /* This causes some problems, as it changes the error status */
4427 /* my_pclose(info->fp); */
4429 /* If we did not have a file pointer open, then we have to */
4430 /* clean up here or eventually we will run out of something */
4432 if (info->fp == NULL) {
4433 my_pclose_pinfo(aTHX_ info);
4441 } /* end of safe_popen */
4444 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4446 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4450 TAINT_PROPER("popen");
4451 PERL_FLUSHALL_FOR_CHILD;
4452 return safe_popen(aTHX_ cmd,mode,&sts);
4458 /* Routine to close and cleanup a pipe info structure */
4460 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4462 unsigned long int retsts;
4466 /* If we were writing to a subprocess, insure that someone reading from
4467 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4468 * produce an EOF record in the mailbox.
4470 * well, at least sometimes it *does*, so we have to watch out for
4471 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4475 #if defined(USE_ITHREADS)
4479 && PL_perlio_fd_refcnt
4482 PerlIO_flush(info->fp);
4484 fflush((FILE *)info->fp);
4487 _ckvmssts(sys$setast(0));
4488 info->closing = TRUE;
4489 done = info->done && info->in_done && info->out_done && info->err_done;
4490 /* hanging on write to Perl's input? cancel it */
4491 if (info->mode == 'r' && info->out && !info->out_done) {
4492 if (info->out->chan_out) {
4493 _ckvmssts(sys$cancel(info->out->chan_out));
4494 if (!info->out->chan_in) { /* EOF generation, need AST */
4495 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4499 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4500 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4502 _ckvmssts(sys$setast(1));
4505 #if defined(USE_ITHREADS)
4509 && PL_perlio_fd_refcnt
4512 PerlIO_close(info->fp);
4514 fclose((FILE *)info->fp);
4517 we have to wait until subprocess completes, but ALSO wait until all
4518 the i/o completes...otherwise we'll be freeing the "info" structure
4519 that the i/o ASTs could still be using...
4523 _ckvmssts(sys$setast(0));
4524 done = info->done && info->in_done && info->out_done && info->err_done;
4525 if (!done) _ckvmssts(sys$clref(pipe_ef));
4526 _ckvmssts(sys$setast(1));
4527 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4529 retsts = info->completion;
4531 /* remove from list of open pipes */
4532 _ckvmssts(sys$setast(0));
4534 for (next = open_pipes; next != NULL; last = next, next = next->next) {
4540 last->next = info->next;
4542 open_pipes = info->next;
4543 _ckvmssts(sys$setast(1));
4545 /* free buffers and structures */
4548 if (info->in->buf) {
4549 n = info->in->bufsize * sizeof(char);
4550 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4553 _ckvmssts(lib$free_vm(&n, &info->in));
4556 if (info->out->buf) {
4557 n = info->out->bufsize * sizeof(char);
4558 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4561 _ckvmssts(lib$free_vm(&n, &info->out));
4564 if (info->err->buf) {
4565 n = info->err->bufsize * sizeof(char);
4566 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4569 _ckvmssts(lib$free_vm(&n, &info->err));
4572 _ckvmssts(lib$free_vm(&n, &info));
4578 /*{{{ I32 my_pclose(PerlIO *fp)*/
4579 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4581 pInfo info, last = NULL;
4584 /* Fixme - need ast and mutex protection here */
4585 for (info = open_pipes; info != NULL; last = info, info = info->next)
4586 if (info->fp == fp) break;
4588 if (info == NULL) { /* no such pipe open */
4589 set_errno(ECHILD); /* quoth POSIX */
4590 set_vaxc_errno(SS$_NONEXPR);
4594 ret_status = my_pclose_pinfo(aTHX_ info);
4598 } /* end of my_pclose() */
4600 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4601 /* Roll our own prototype because we want this regardless of whether
4602 * _VMS_WAIT is defined.
4608 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4614 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4615 created with popen(); otherwise partially emulate waitpid() unless
4616 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4617 Also check processes not considered by the CRTL waitpid().
4619 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4621 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4628 if (statusp) *statusp = 0;
4630 for (info = open_pipes; info != NULL; info = info->next)
4631 if (info->pid == pid) break;
4633 if (info != NULL) { /* we know about this child */
4634 while (!info->done) {
4635 _ckvmssts(sys$setast(0));
4637 if (!done) _ckvmssts(sys$clref(pipe_ef));
4638 _ckvmssts(sys$setast(1));
4639 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4642 if (statusp) *statusp = info->completion;
4646 /* child that already terminated? */
4648 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4649 if (closed_list[j].pid == pid) {
4650 if (statusp) *statusp = closed_list[j].completion;
4655 /* fall through if this child is not one of our own pipe children */
4657 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4659 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4660 * in 7.2 did we get a version that fills in the VMS completion
4661 * status as Perl has always tried to do.
4664 sts = __vms_waitpid( pid, statusp, flags );
4666 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4669 /* If the real waitpid tells us the child does not exist, we
4670 * fall through here to implement waiting for a child that
4671 * was created by some means other than exec() (say, spawned
4672 * from DCL) or to wait for a process that is not a subprocess
4673 * of the current process.
4676 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4679 $DESCRIPTOR(intdsc,"0 00:00:01");
4680 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4681 unsigned long int pidcode = JPI$_PID, mypid;
4682 unsigned long int interval[2];
4683 unsigned int jpi_iosb[2];
4684 struct itmlst_3 jpilist[2] = {
4685 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4690 /* Sorry folks, we don't presently implement rooting around for
4691 the first child we can find, and we definitely don't want to
4692 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4698 /* Get the owner of the child so I can warn if it's not mine. If the
4699 * process doesn't exist or I don't have the privs to look at it,
4700 * I can go home early.
4702 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4703 if (sts & 1) sts = jpi_iosb[0];
4715 set_vaxc_errno(sts);
4719 if (ckWARN(WARN_EXEC)) {
4720 /* remind folks they are asking for non-standard waitpid behavior */
4721 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4722 if (ownerpid != mypid)
4723 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4724 "waitpid: process %x is not a child of process %x",
4728 /* simply check on it once a second until it's not there anymore. */
4730 _ckvmssts(sys$bintim(&intdsc,interval));
4731 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4732 _ckvmssts(sys$schdwk(0,0,interval,0));
4733 _ckvmssts(sys$hiber());
4735 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4740 } /* end of waitpid() */
4745 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4747 my_gconvert(double val, int ndig, int trail, char *buf)
4749 static char __gcvtbuf[DBL_DIG+1];
4752 loc = buf ? buf : __gcvtbuf;
4755 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4756 return gcvt(val,ndig,loc);
4759 loc[0] = '0'; loc[1] = '\0';
4766 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4767 static int rms_free_search_context(struct FAB * fab)
4771 nam = fab->fab$l_nam;
4772 nam->nam$b_nop |= NAM$M_SYNCHK;
4773 nam->nam$l_rlf = NULL;
4775 return sys$parse(fab, NULL, NULL);
4778 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4779 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4780 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4781 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4782 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4783 #define rms_nam_esll(nam) nam.nam$b_esl
4784 #define rms_nam_esl(nam) nam.nam$b_esl
4785 #define rms_nam_name(nam) nam.nam$l_name
4786 #define rms_nam_namel(nam) nam.nam$l_name
4787 #define rms_nam_type(nam) nam.nam$l_type
4788 #define rms_nam_typel(nam) nam.nam$l_type
4789 #define rms_nam_ver(nam) nam.nam$l_ver
4790 #define rms_nam_verl(nam) nam.nam$l_ver
4791 #define rms_nam_rsll(nam) nam.nam$b_rsl
4792 #define rms_nam_rsl(nam) nam.nam$b_rsl
4793 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4794 #define rms_set_fna(fab, nam, name, size) \
4795 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4796 #define rms_get_fna(fab, nam) fab.fab$l_fna
4797 #define rms_set_dna(fab, nam, name, size) \
4798 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4799 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4800 #define rms_set_esa(nam, name, size) \
4801 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4802 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4803 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4804 #define rms_set_rsa(nam, name, size) \
4805 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4806 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4807 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4808 #define rms_nam_name_type_l_size(nam) \
4809 (nam.nam$b_name + nam.nam$b_type)
4811 static int rms_free_search_context(struct FAB * fab)
4815 nam = fab->fab$l_naml;
4816 nam->naml$b_nop |= NAM$M_SYNCHK;
4817 nam->naml$l_rlf = NULL;
4818 nam->naml$l_long_defname_size = 0;
4821 return sys$parse(fab, NULL, NULL);
4824 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4825 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4826 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4827 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4828 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4829 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4830 #define rms_nam_esl(nam) nam.naml$b_esl
4831 #define rms_nam_name(nam) nam.naml$l_name
4832 #define rms_nam_namel(nam) nam.naml$l_long_name
4833 #define rms_nam_type(nam) nam.naml$l_type
4834 #define rms_nam_typel(nam) nam.naml$l_long_type
4835 #define rms_nam_ver(nam) nam.naml$l_ver
4836 #define rms_nam_verl(nam) nam.naml$l_long_ver
4837 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4838 #define rms_nam_rsl(nam) nam.naml$b_rsl
4839 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4840 #define rms_set_fna(fab, nam, name, size) \
4841 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4842 nam.naml$l_long_filename_size = size; \
4843 nam.naml$l_long_filename = name;}
4844 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4845 #define rms_set_dna(fab, nam, name, size) \