3 * VMS-specific routines for perl5
6 * August 2005 Convert VMS status code to UNIX status codes
7 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
8 * and Perl_cando by Craig Berry
9 * 29-Aug-2000 Charles Lane's piping improvements rolled in
10 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
19 #include <climsgdef.h>
30 #include <libclidef.h>
32 #include <lib$routines.h>
35 #if __CRTL_VER >= 70301000 && !defined(__VAX)
45 #include <str$routines.h>
52 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
54 #define NO_EFN EFN$C_ENF
59 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
60 int decc$feature_get_index(const char *name);
61 char* decc$feature_get_name(int index);
62 int decc$feature_get_value(int index, int mode);
63 int decc$feature_set_value(int index, int mode, int value);
68 #pragma member_alignment save
69 #pragma nomember_alignment longword
74 unsigned short * retadr;
76 #pragma member_alignment restore
78 /* More specific prototype than in starlet_c.h makes programming errors
86 const struct dsc$descriptor_s * devnam,
87 const struct item_list_3 * itmlst,
89 void * (astadr)(unsigned long),
94 #if __CRTL_VER >= 70300000 && !defined(__VAX)
96 static int set_feature_default(const char *name, int value)
101 index = decc$feature_get_index(name);
103 status = decc$feature_set_value(index, 1, value);
104 if (index == -1 || (status == -1)) {
108 status = decc$feature_get_value(index, 1);
109 if (status != value) {
117 /* Older versions of ssdef.h don't have these */
118 #ifndef SS$_INVFILFOROP
119 # define SS$_INVFILFOROP 3930
121 #ifndef SS$_NOSUCHOBJECT
122 # define SS$_NOSUCHOBJECT 2696
125 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
126 #define PERLIO_NOT_STDIO 0
128 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
129 * code below needs to get to the underlying CRTL routines. */
130 #define DONT_MASK_RTL_CALLS
134 /* Anticipating future expansion in lexical warnings . . . */
135 #ifndef WARN_INTERNAL
136 # define WARN_INTERNAL WARN_MISC
139 #ifdef VMS_LONGNAME_SUPPORT
140 #include <libfildef.h>
143 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
144 # define RTL_USES_UTC 1
147 #ifdef USE_VMS_DECTERM
149 /* Routine to create a decterm for use with the Perl debugger */
150 /* No headers, this information was found in the Programming Concepts Manual */
153 (const struct dsc$descriptor_s * display,
154 const struct dsc$descriptor_s * setup_file,
155 const struct dsc$descriptor_s * customization,
156 struct dsc$descriptor_s * result_device_name,
157 unsigned short * result_device_name_length,
160 void * char_change_buffer);
163 /* gcc's header files don't #define direct access macros
164 * corresponding to VAXC's variant structs */
166 # define uic$v_format uic$r_uic_form.uic$v_format
167 # define uic$v_group uic$r_uic_form.uic$v_group
168 # define uic$v_member uic$r_uic_form.uic$v_member
169 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
170 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
171 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
172 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
175 #if defined(NEED_AN_H_ERRNO)
180 #pragma message disable pragma
181 #pragma member_alignment save
182 #pragma nomember_alignment longword
184 #pragma message disable misalgndmem
187 unsigned short int buflen;
188 unsigned short int itmcode;
190 unsigned short int *retlen;
193 struct filescan_itmlst_2 {
194 unsigned short length;
195 unsigned short itmcode;
200 unsigned short length;
205 #pragma message restore
206 #pragma member_alignment restore
209 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
210 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
211 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
212 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
213 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
214 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
215 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
216 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
217 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
218 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
219 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
221 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
222 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
223 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
224 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
226 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
227 #define PERL_LNM_MAX_ALLOWED_INDEX 127
229 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
230 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
233 #define PERL_LNM_MAX_ITER 10
235 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
236 #if __CRTL_VER >= 70302000 && !defined(__VAX)
237 #define MAX_DCL_SYMBOL (8192)
238 #define MAX_DCL_LINE_LENGTH (4096 - 4)
240 #define MAX_DCL_SYMBOL (1024)
241 #define MAX_DCL_LINE_LENGTH (1024 - 4)
244 static char *__mystrtolower(char *str)
246 if (str) for (; *str; ++str) *str= tolower(*str);
250 static struct dsc$descriptor_s fildevdsc =
251 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
252 static struct dsc$descriptor_s crtlenvdsc =
253 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
254 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
255 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
256 static struct dsc$descriptor_s **env_tables = defenv;
257 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
259 /* True if we shouldn't treat barewords as logicals during directory */
261 static int no_translate_barewords;
264 static int tz_updated = 1;
267 /* DECC Features that may need to affect how Perl interprets
268 * displays filename information
270 static int decc_disable_to_vms_logname_translation = 1;
271 static int decc_disable_posix_root = 1;
272 int decc_efs_case_preserve = 0;
273 static int decc_efs_charset = 0;
274 static int decc_filename_unix_no_version = 0;
275 static int decc_filename_unix_only = 0;
276 int decc_filename_unix_report = 0;
277 int decc_posix_compliant_pathnames = 0;
278 int decc_readdir_dropdotnotype = 0;
279 static int vms_process_case_tolerant = 1;
280 int vms_vtf7_filenames = 0;
281 int gnv_unix_shell = 0;
283 /* bug workarounds if needed */
284 int decc_bug_readdir_efs1 = 0;
285 int decc_bug_devnull = 1;
286 int decc_bug_fgetname = 0;
287 int decc_dir_barename = 0;
289 static int vms_debug_on_exception = 0;
291 /* Is this a UNIX file specification?
292 * No longer a simple check with EFS file specs
293 * For now, not a full check, but need to
294 * handle POSIX ^UP^ specifications
295 * Fixing to handle ^/ cases would require
296 * changes to many other conversion routines.
299 static int is_unix_filespec(const char *path)
305 if (strncmp(path,"\"^UP^",5) != 0) {
306 pch1 = strchr(path, '/');
311 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
312 if (decc_filename_unix_report || decc_filename_unix_only) {
313 if (strcmp(path,".") == 0)
321 /* This routine converts a UCS-2 character to be VTF-7 encoded.
324 static void ucs2_to_vtf7
326 unsigned long ucs2_char,
329 unsigned char * ucs_ptr;
332 ucs_ptr = (unsigned char *)&ucs2_char;
336 hex = (ucs_ptr[1] >> 4) & 0xf;
338 outspec[2] = hex + '0';
340 outspec[2] = (hex - 9) + 'A';
341 hex = ucs_ptr[1] & 0xF;
343 outspec[3] = hex + '0';
345 outspec[3] = (hex - 9) + 'A';
347 hex = (ucs_ptr[0] >> 4) & 0xf;
349 outspec[4] = hex + '0';
351 outspec[4] = (hex - 9) + 'A';
352 hex = ucs_ptr[1] & 0xF;
354 outspec[5] = hex + '0';
356 outspec[5] = (hex - 9) + 'A';
362 /* This handles the conversion of a UNIX extended character set to a ^
363 * escaped VMS character.
364 * in a UNIX file specification.
366 * The output count variable contains the number of characters added
367 * to the output string.
369 * The return value is the number of characters read from the input string
371 static int copy_expand_unix_filename_escape
372 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
380 utf8_flag = *utf8_fl;
384 if (*inspec >= 0x80) {
385 if (utf8_fl && vms_vtf7_filenames) {
386 unsigned long ucs_char;
390 if ((*inspec & 0xE0) == 0xC0) {
392 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
393 if (ucs_char >= 0x80) {
394 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
397 } else if ((*inspec & 0xF0) == 0xE0) {
399 ucs_char = ((inspec[0] & 0xF) << 12) +
400 ((inspec[1] & 0x3f) << 6) +
402 if (ucs_char >= 0x800) {
403 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
407 #if 0 /* I do not see longer sequences supported by OpenVMS */
408 /* Maybe some one can fix this later */
409 } else if ((*inspec & 0xF8) == 0xF0) {
412 } else if ((*inspec & 0xFC) == 0xF8) {
415 } else if ((*inspec & 0xFE) == 0xFC) {
422 /* High bit set, but not a unicode character! */
424 /* Non printing DECMCS or ISO Latin-1 character? */
425 if (*inspec <= 0x9F) {
429 hex = (*inspec >> 4) & 0xF;
431 outspec[1] = hex + '0';
433 outspec[1] = (hex - 9) + 'A';
437 outspec[2] = hex + '0';
439 outspec[2] = (hex - 9) + 'A';
443 } else if (*inspec == 0xA0) {
449 } else if (*inspec == 0xFF) {
461 /* Is this a macro that needs to be passed through?
462 * Macros start with $( and an alpha character, followed
463 * by a string of alpha numeric characters ending with a )
464 * If this does not match, then encode it as ODS-5.
466 if ((inspec[0] == '$') && (inspec[1] == '(')) {
469 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
471 outspec[0] = inspec[0];
472 outspec[1] = inspec[1];
473 outspec[2] = inspec[2];
475 while(isalnum(inspec[tcnt]) ||
476 (inspec[2] == '.') || (inspec[2] == '_')) {
477 outspec[tcnt] = inspec[tcnt];
480 if (inspec[tcnt] == ')') {
481 outspec[tcnt] = inspec[tcnt];
498 if (decc_efs_charset == 0)
525 /* Assume that this is to be escaped */
527 outspec[1] = *inspec;
531 case ' ': /* space */
532 /* Assume that this is to be escaped */
547 /* This handles the expansion of a '^' prefix to the proper character
548 * in a UNIX file specification.
550 * The output count variable contains the number of characters added
551 * to the output string.
553 * The return value is the number of characters read from the input
556 static int copy_expand_vms_filename_escape
557 (char *outspec, const char *inspec, int *output_cnt)
564 if (*inspec == '^') {
568 /* Non trailing dots should just be passed through */
573 case '_': /* space */
579 case 'U': /* Unicode - FIX-ME this is wrong. */
582 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
585 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
586 outspec[0] == c1 & 0xff;
587 outspec[1] == c2 & 0xff;
594 /* Error - do best we can to continue */
604 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
608 scnt = sscanf(inspec, "%2x", &c1);
609 outspec[0] = c1 & 0xff;
633 (const struct dsc$descriptor_s * srcstr,
634 struct filescan_itmlst_2 * valuelist,
635 unsigned long * fldflags,
636 struct dsc$descriptor_s *auxout,
637 unsigned short * retlen);
640 /* vms_split_path - Verify that the input file specification is a
641 * VMS format file specification, and provide pointers to the components of
642 * it. With EFS format filenames, this is virtually the only way to
643 * parse a VMS path specification into components.
645 * If the sum of the components do not add up to the length of the
646 * string, then the passed file specification is probably a UNIX style
649 static int vms_split_path
664 struct dsc$descriptor path_desc;
668 struct filescan_itmlst_2 item_list[9];
669 const int filespec = 0;
670 const int nodespec = 1;
671 const int devspec = 2;
672 const int rootspec = 3;
673 const int dirspec = 4;
674 const int namespec = 5;
675 const int typespec = 6;
676 const int verspec = 7;
678 /* Assume the worst for an easy exit */
693 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
694 path_desc.dsc$w_length = strlen(path);
695 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
696 path_desc.dsc$b_class = DSC$K_CLASS_S;
698 /* Get the total length, if it is shorter than the string passed
699 * then this was probably not a VMS formatted file specification
701 item_list[filespec].itmcode = FSCN$_FILESPEC;
702 item_list[filespec].length = 0;
703 item_list[filespec].component = NULL;
705 /* If the node is present, then it gets considered as part of the
706 * volume name to hopefully make things simple.
708 item_list[nodespec].itmcode = FSCN$_NODE;
709 item_list[nodespec].length = 0;
710 item_list[nodespec].component = NULL;
712 item_list[devspec].itmcode = FSCN$_DEVICE;
713 item_list[devspec].length = 0;
714 item_list[devspec].component = NULL;
716 /* root is a special case, adding it to either the directory or
717 * the device components will probalby complicate things for the
718 * callers of this routine, so leave it separate.
720 item_list[rootspec].itmcode = FSCN$_ROOT;
721 item_list[rootspec].length = 0;
722 item_list[rootspec].component = NULL;
724 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
725 item_list[dirspec].length = 0;
726 item_list[dirspec].component = NULL;
728 item_list[namespec].itmcode = FSCN$_NAME;
729 item_list[namespec].length = 0;
730 item_list[namespec].component = NULL;
732 item_list[typespec].itmcode = FSCN$_TYPE;
733 item_list[typespec].length = 0;
734 item_list[typespec].component = NULL;
736 item_list[verspec].itmcode = FSCN$_VERSION;
737 item_list[verspec].length = 0;
738 item_list[verspec].component = NULL;
740 item_list[8].itmcode = 0;
741 item_list[8].length = 0;
742 item_list[8].component = NULL;
744 status = sys$filescan
745 ((const struct dsc$descriptor_s *)&path_desc, item_list,
747 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
749 /* If we parsed it successfully these two lengths should be the same */
750 if (path_desc.dsc$w_length != item_list[filespec].length)
753 /* If we got here, then it is a VMS file specification */
756 /* set the volume name */
757 if (item_list[nodespec].length > 0) {
758 *volume = item_list[nodespec].component;
759 *vol_len = item_list[nodespec].length + item_list[devspec].length;
762 *volume = item_list[devspec].component;
763 *vol_len = item_list[devspec].length;
766 *root = item_list[rootspec].component;
767 *root_len = item_list[rootspec].length;
769 *dir = item_list[dirspec].component;
770 *dir_len = item_list[dirspec].length;
772 /* Now fun with versions and EFS file specifications
773 * The parser can not tell the difference when a "." is a version
774 * delimiter or a part of the file specification.
776 if ((decc_efs_charset) &&
777 (item_list[verspec].length > 0) &&
778 (item_list[verspec].component[0] == '.')) {
779 *name = item_list[namespec].component;
780 *name_len = item_list[namespec].length + item_list[typespec].length;
781 *ext = item_list[verspec].component;
782 *ext_len = item_list[verspec].length;
787 *name = item_list[namespec].component;
788 *name_len = item_list[namespec].length;
789 *ext = item_list[typespec].component;
790 *ext_len = item_list[typespec].length;
791 *version = item_list[verspec].component;
792 *ver_len = item_list[verspec].length;
799 * Routine to retrieve the maximum equivalence index for an input
800 * logical name. Some calls to this routine have no knowledge if
801 * the variable is a logical or not. So on error we return a max
804 /*{{{int my_maxidx(const char *lnm) */
806 my_maxidx(const char *lnm)
810 int attr = LNM$M_CASE_BLIND;
811 struct dsc$descriptor lnmdsc;
812 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
815 lnmdsc.dsc$w_length = strlen(lnm);
816 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
817 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
818 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
820 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
821 if ((status & 1) == 0)
828 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
830 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
831 struct dsc$descriptor_s **tabvec, unsigned long int flags)
834 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
835 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
836 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
838 unsigned char acmode;
839 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
840 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
841 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
842 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
844 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
845 #if defined(PERL_IMPLICIT_CONTEXT)
848 aTHX = PERL_GET_INTERP;
854 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
855 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
857 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
858 *cp2 = _toupper(*cp1);
859 if (cp1 - lnm > LNM$C_NAMLENGTH) {
860 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
864 lnmdsc.dsc$w_length = cp1 - lnm;
865 lnmdsc.dsc$a_pointer = uplnm;
866 uplnm[lnmdsc.dsc$w_length] = '\0';
867 secure = flags & PERL__TRNENV_SECURE;
868 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
869 if (!tabvec || !*tabvec) tabvec = env_tables;
871 for (curtab = 0; tabvec[curtab]; curtab++) {
872 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
873 if (!ivenv && !secure) {
878 Perl_warn(aTHX_ "Can't read CRTL environ\n");
881 retsts = SS$_NOLOGNAM;
882 for (i = 0; environ[i]; i++) {
883 if ((eq = strchr(environ[i],'=')) &&
884 lnmdsc.dsc$w_length == (eq - environ[i]) &&
885 !strncmp(environ[i],uplnm,eq - environ[i])) {
887 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
888 if (!eqvlen) continue;
893 if (retsts != SS$_NOLOGNAM) break;
896 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
897 !str$case_blind_compare(&tmpdsc,&clisym)) {
898 if (!ivsym && !secure) {
899 unsigned short int deflen = LNM$C_NAMLENGTH;
900 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
901 /* dynamic dsc to accomodate possible long value */
902 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
903 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
905 if (eqvlen > MAX_DCL_SYMBOL) {
906 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
907 eqvlen = MAX_DCL_SYMBOL;
908 /* Special hack--we might be called before the interpreter's */
909 /* fully initialized, in which case either thr or PL_curcop */
910 /* might be bogus. We have to check, since ckWARN needs them */
911 /* both to be valid if running threaded */
912 if (ckWARN(WARN_MISC)) {
913 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
916 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
918 _ckvmssts(lib$sfree1_dd(&eqvdsc));
919 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
920 if (retsts == LIB$_NOSUCHSYM) continue;
925 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
926 midx = my_maxidx(lnm);
927 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
928 lnmlst[1].bufadr = cp2;
930 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
931 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
932 if (retsts == SS$_NOLOGNAM) break;
933 /* PPFs have a prefix */
936 *((int *)uplnm) == *((int *)"SYS$") &&
938 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
939 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
940 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
941 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
942 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
943 memmove(eqv,eqv+4,eqvlen-4);
949 if ((retsts == SS$_IVLOGNAM) ||
950 (retsts == SS$_NOLOGNAM)) { continue; }
953 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
954 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
955 if (retsts == SS$_NOLOGNAM) continue;
958 eqvlen = strlen(eqv);
962 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
963 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
964 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
965 retsts == SS$_NOLOGNAM) {
966 set_errno(EINVAL); set_vaxc_errno(retsts);
968 else _ckvmssts(retsts);
970 } /* end of vmstrnenv */
973 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
974 /* Define as a function so we can access statics. */
975 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
977 return vmstrnenv(lnm,eqv,idx,fildev,
978 #ifdef SECURE_INTERNAL_GETENV
979 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
988 * Note: Uses Perl temp to store result so char * can be returned to
989 * caller; this pointer will be invalidated at next Perl statement
991 * We define this as a function rather than a macro in terms of my_getenv_len()
992 * so that it'll work when PL_curinterp is undefined (and we therefore can't
995 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
997 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1000 static char *__my_getenv_eqv = NULL;
1001 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1002 unsigned long int idx = 0;
1003 int trnsuccess, success, secure, saverr, savvmserr;
1007 midx = my_maxidx(lnm) + 1;
1009 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1010 /* Set up a temporary buffer for the return value; Perl will
1011 * clean it up at the next statement transition */
1012 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1013 if (!tmpsv) return NULL;
1017 /* Assume no interpreter ==> single thread */
1018 if (__my_getenv_eqv != NULL) {
1019 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1022 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1024 eqv = __my_getenv_eqv;
1027 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1028 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1030 getcwd(eqv,LNM$C_NAMLENGTH);
1034 /* Get rid of "000000/ in rooted filespecs */
1037 zeros = strstr(eqv, "/000000/");
1038 if (zeros != NULL) {
1040 mlen = len - (zeros - eqv) - 7;
1041 memmove(zeros, &zeros[7], mlen);
1049 /* Impose security constraints only if tainting */
1051 /* Impose security constraints only if tainting */
1052 secure = PL_curinterp ? PL_tainting : will_taint;
1053 saverr = errno; savvmserr = vaxc$errno;
1060 #ifdef SECURE_INTERNAL_GETENV
1061 secure ? PERL__TRNENV_SECURE : 0
1067 /* For the getenv interface we combine all the equivalence names
1068 * of a search list logical into one value to acquire a maximum
1069 * value length of 255*128 (assuming %ENV is using logicals).
1071 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1073 /* If the name contains a semicolon-delimited index, parse it
1074 * off and make sure we only retrieve the equivalence name for
1076 if ((cp2 = strchr(lnm,';')) != NULL) {
1078 uplnm[cp2-lnm] = '\0';
1079 idx = strtoul(cp2+1,NULL,0);
1081 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1084 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1086 /* Discard NOLOGNAM on internal calls since we're often looking
1087 * for an optional name, and this "error" often shows up as the
1088 * (bogus) exit status for a die() call later on. */
1089 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1090 return success ? eqv : Nullch;
1093 } /* end of my_getenv() */
1097 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1099 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1103 unsigned long idx = 0;
1105 static char *__my_getenv_len_eqv = NULL;
1106 int secure, saverr, savvmserr;
1109 midx = my_maxidx(lnm) + 1;
1111 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1112 /* Set up a temporary buffer for the return value; Perl will
1113 * clean it up at the next statement transition */
1114 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1115 if (!tmpsv) return NULL;
1119 /* Assume no interpreter ==> single thread */
1120 if (__my_getenv_len_eqv != NULL) {
1121 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1124 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1126 buf = __my_getenv_len_eqv;
1129 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1130 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1133 getcwd(buf,LNM$C_NAMLENGTH);
1136 /* Get rid of "000000/ in rooted filespecs */
1138 zeros = strstr(buf, "/000000/");
1139 if (zeros != NULL) {
1141 mlen = *len - (zeros - buf) - 7;
1142 memmove(zeros, &zeros[7], mlen);
1151 /* Impose security constraints only if tainting */
1152 secure = PL_curinterp ? PL_tainting : will_taint;
1153 saverr = errno; savvmserr = vaxc$errno;
1160 #ifdef SECURE_INTERNAL_GETENV
1161 secure ? PERL__TRNENV_SECURE : 0
1167 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1169 if ((cp2 = strchr(lnm,';')) != NULL) {
1171 buf[cp2-lnm] = '\0';
1172 idx = strtoul(cp2+1,NULL,0);
1174 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1177 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1179 /* Get rid of "000000/ in rooted filespecs */
1182 zeros = strstr(buf, "/000000/");
1183 if (zeros != NULL) {
1185 mlen = *len - (zeros - buf) - 7;
1186 memmove(zeros, &zeros[7], mlen);
1192 /* Discard NOLOGNAM on internal calls since we're often looking
1193 * for an optional name, and this "error" often shows up as the
1194 * (bogus) exit status for a die() call later on. */
1195 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1196 return *len ? buf : Nullch;
1199 } /* end of my_getenv_len() */
1202 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1204 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1206 /*{{{ void prime_env_iter() */
1208 prime_env_iter(void)
1209 /* Fill the %ENV associative array with all logical names we can
1210 * find, in preparation for iterating over it.
1213 static int primed = 0;
1214 HV *seenhv = NULL, *envhv;
1216 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1217 unsigned short int chan;
1218 #ifndef CLI$M_TRUSTED
1219 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1221 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1222 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1224 bool have_sym = FALSE, have_lnm = FALSE;
1225 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1226 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1227 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1228 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1229 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1230 #if defined(PERL_IMPLICIT_CONTEXT)
1233 #if defined(USE_ITHREADS)
1234 static perl_mutex primenv_mutex;
1235 MUTEX_INIT(&primenv_mutex);
1238 #if defined(PERL_IMPLICIT_CONTEXT)
1239 /* We jump through these hoops because we can be called at */
1240 /* platform-specific initialization time, which is before anything is */
1241 /* set up--we can't even do a plain dTHX since that relies on the */
1242 /* interpreter structure to be initialized */
1244 aTHX = PERL_GET_INTERP;
1250 if (primed || !PL_envgv) return;
1251 MUTEX_LOCK(&primenv_mutex);
1252 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1253 envhv = GvHVn(PL_envgv);
1254 /* Perform a dummy fetch as an lval to insure that the hash table is
1255 * set up. Otherwise, the hv_store() will turn into a nullop. */
1256 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1258 for (i = 0; env_tables[i]; i++) {
1259 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1260 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1261 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1263 if (have_sym || have_lnm) {
1264 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1265 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1266 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1267 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1270 for (i--; i >= 0; i--) {
1271 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1274 for (j = 0; environ[j]; j++) {
1275 if (!(start = strchr(environ[j],'='))) {
1276 if (ckWARN(WARN_INTERNAL))
1277 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1281 sv = newSVpv(start,0);
1283 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1288 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1289 !str$case_blind_compare(&tmpdsc,&clisym)) {
1290 strcpy(cmd,"Show Symbol/Global *");
1291 cmddsc.dsc$w_length = 20;
1292 if (env_tables[i]->dsc$w_length == 12 &&
1293 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1294 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1295 flags = defflags | CLI$M_NOLOGNAM;
1298 strcpy(cmd,"Show Logical *");
1299 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1300 strcat(cmd," /Table=");
1301 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1302 cmddsc.dsc$w_length = strlen(cmd);
1304 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1305 flags = defflags | CLI$M_NOCLISYM;
1308 /* Create a new subprocess to execute each command, to exclude the
1309 * remote possibility that someone could subvert a mbx or file used
1310 * to write multiple commands to a single subprocess.
1313 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1314 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1315 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1316 defflags &= ~CLI$M_TRUSTED;
1317 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1319 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1320 if (seenhv) SvREFCNT_dec(seenhv);
1323 char *cp1, *cp2, *key;
1324 unsigned long int sts, iosb[2], retlen, keylen;
1327 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1328 if (sts & 1) sts = iosb[0] & 0xffff;
1329 if (sts == SS$_ENDOFFILE) {
1331 while (substs == 0) { sys$hiber(); wakect++;}
1332 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1337 retlen = iosb[0] >> 16;
1338 if (!retlen) continue; /* blank line */
1340 if (iosb[1] != subpid) {
1342 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1346 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1347 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1349 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1350 if (*cp1 == '(' || /* Logical name table name */
1351 *cp1 == '=' /* Next eqv of searchlist */) continue;
1352 if (*cp1 == '"') cp1++;
1353 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1354 key = cp1; keylen = cp2 - cp1;
1355 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1356 while (*cp2 && *cp2 != '=') cp2++;
1357 while (*cp2 && *cp2 == '=') cp2++;
1358 while (*cp2 && *cp2 == ' ') cp2++;
1359 if (*cp2 == '"') { /* String translation; may embed "" */
1360 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1361 cp2++; cp1--; /* Skip "" surrounding translation */
1363 else { /* Numeric translation */
1364 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1365 cp1--; /* stop on last non-space char */
1367 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1368 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1371 PERL_HASH(hash,key,keylen);
1373 if (cp1 == cp2 && *cp2 == '.') {
1374 /* A single dot usually means an unprintable character, such as a null
1375 * to indicate a zero-length value. Get the actual value to make sure.
1377 char lnm[LNM$C_NAMLENGTH+1];
1378 char eqv[MAX_DCL_SYMBOL+1];
1380 strncpy(lnm, key, keylen);
1381 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1382 sv = newSVpvn(eqv, strlen(eqv));
1385 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1389 hv_store(envhv,key,keylen,sv,hash);
1390 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1392 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1393 /* get the PPFs for this process, not the subprocess */
1394 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1395 char eqv[LNM$C_NAMLENGTH+1];
1397 for (i = 0; ppfs[i]; i++) {
1398 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1399 sv = newSVpv(eqv,trnlen);
1401 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1406 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1407 if (buf) Safefree(buf);
1408 if (seenhv) SvREFCNT_dec(seenhv);
1409 MUTEX_UNLOCK(&primenv_mutex);
1412 } /* end of prime_env_iter */
1416 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1417 /* Define or delete an element in the same "environment" as
1418 * vmstrnenv(). If an element is to be deleted, it's removed from
1419 * the first place it's found. If it's to be set, it's set in the
1420 * place designated by the first element of the table vector.
1421 * Like setenv() returns 0 for success, non-zero on error.
1424 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1427 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1428 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1430 unsigned long int retsts, usermode = PSL$C_USER;
1431 struct itmlst_3 *ile, *ilist;
1432 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1433 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1434 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1435 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1436 $DESCRIPTOR(local,"_LOCAL");
1439 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1440 return SS$_IVLOGNAM;
1443 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1444 *cp2 = _toupper(*cp1);
1445 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1446 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1447 return SS$_IVLOGNAM;
1450 lnmdsc.dsc$w_length = cp1 - lnm;
1451 if (!tabvec || !*tabvec) tabvec = env_tables;
1453 if (!eqv) { /* we're deleting n element */
1454 for (curtab = 0; tabvec[curtab]; curtab++) {
1455 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1457 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1458 if ((cp1 = strchr(environ[i],'=')) &&
1459 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1460 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1462 return setenv(lnm,"",1) ? vaxc$errno : 0;
1465 ivenv = 1; retsts = SS$_NOLOGNAM;
1467 if (ckWARN(WARN_INTERNAL))
1468 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1469 ivenv = 1; retsts = SS$_NOSUCHPGM;
1475 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1476 !str$case_blind_compare(&tmpdsc,&clisym)) {
1477 unsigned int symtype;
1478 if (tabvec[curtab]->dsc$w_length == 12 &&
1479 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1480 !str$case_blind_compare(&tmpdsc,&local))
1481 symtype = LIB$K_CLI_LOCAL_SYM;
1482 else symtype = LIB$K_CLI_GLOBAL_SYM;
1483 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1484 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1485 if (retsts == LIB$_NOSUCHSYM) continue;
1489 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1490 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1491 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1492 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1493 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1497 else { /* we're defining a value */
1498 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1500 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1502 if (ckWARN(WARN_INTERNAL))
1503 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1504 retsts = SS$_NOSUCHPGM;
1508 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1509 eqvdsc.dsc$w_length = strlen(eqv);
1510 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1511 !str$case_blind_compare(&tmpdsc,&clisym)) {
1512 unsigned int symtype;
1513 if (tabvec[0]->dsc$w_length == 12 &&
1514 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1515 !str$case_blind_compare(&tmpdsc,&local))
1516 symtype = LIB$K_CLI_LOCAL_SYM;
1517 else symtype = LIB$K_CLI_GLOBAL_SYM;
1518 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1521 if (!*eqv) eqvdsc.dsc$w_length = 1;
1522 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1524 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1525 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1526 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1527 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1528 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1529 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1532 Newx(ilist,nseg+1,struct itmlst_3);
1535 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1538 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1540 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1541 ile->itmcode = LNM$_STRING;
1543 if ((j+1) == nseg) {
1544 ile->buflen = strlen(c);
1545 /* in case we are truncating one that's too long */
1546 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1549 ile->buflen = LNM$C_NAMLENGTH;
1553 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1557 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1562 if (!(retsts & 1)) {
1564 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1565 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1566 set_errno(EVMSERR); break;
1567 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1568 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1569 set_errno(EINVAL); break;
1571 set_errno(EACCES); break;
1576 set_vaxc_errno(retsts);
1577 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1580 /* We reset error values on success because Perl does an hv_fetch()
1581 * before each hv_store(), and if the thing we're setting didn't
1582 * previously exist, we've got a leftover error message. (Of course,
1583 * this fails in the face of
1584 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1585 * in that the error reported in $! isn't spurious,
1586 * but it's right more often than not.)
1588 set_errno(0); set_vaxc_errno(retsts);
1592 } /* end of vmssetenv() */
1595 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1596 /* This has to be a function since there's a prototype for it in proto.h */
1598 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1601 int len = strlen(lnm);
1605 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1606 if (!strcmp(uplnm,"DEFAULT")) {
1607 if (eqv && *eqv) my_chdir(eqv);
1611 #ifndef RTL_USES_UTC
1612 if (len == 6 || len == 2) {
1615 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1617 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1618 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1622 (void) vmssetenv(lnm,eqv,NULL);
1626 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1628 * sets a user-mode logical in the process logical name table
1629 * used for redirection of sys$error
1632 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1634 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1635 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1636 unsigned long int iss, attr = LNM$M_CONFINE;
1637 unsigned char acmode = PSL$C_USER;
1638 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1640 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1641 d_name.dsc$w_length = strlen(name);
1643 lnmlst[0].buflen = strlen(eqv);
1644 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1646 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1647 if (!(iss&1)) lib$signal(iss);
1652 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1653 /* my_crypt - VMS password hashing
1654 * my_crypt() provides an interface compatible with the Unix crypt()
1655 * C library function, and uses sys$hash_password() to perform VMS
1656 * password hashing. The quadword hashed password value is returned
1657 * as a NUL-terminated 8 character string. my_crypt() does not change
1658 * the case of its string arguments; in order to match the behavior
1659 * of LOGINOUT et al., alphabetic characters in both arguments must
1660 * be upcased by the caller.
1662 * - fix me to call ACM services when available
1665 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1667 # ifndef UAI$C_PREFERRED_ALGORITHM
1668 # define UAI$C_PREFERRED_ALGORITHM 127
1670 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1671 unsigned short int salt = 0;
1672 unsigned long int sts;
1674 unsigned short int dsc$w_length;
1675 unsigned char dsc$b_type;
1676 unsigned char dsc$b_class;
1677 const char * dsc$a_pointer;
1678 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1679 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1680 struct itmlst_3 uailst[3] = {
1681 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1682 { sizeof salt, UAI$_SALT, &salt, 0},
1683 { 0, 0, NULL, NULL}};
1684 static char hash[9];
1686 usrdsc.dsc$w_length = strlen(usrname);
1687 usrdsc.dsc$a_pointer = usrname;
1688 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1690 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1694 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1699 set_vaxc_errno(sts);
1700 if (sts != RMS$_RNF) return NULL;
1703 txtdsc.dsc$w_length = strlen(textpasswd);
1704 txtdsc.dsc$a_pointer = textpasswd;
1705 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1706 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1709 return (char *) hash;
1711 } /* end of my_crypt() */
1715 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1716 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1717 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1719 /* fixup barenames that are directories for internal use.
1720 * There have been problems with the consistent handling of UNIX
1721 * style directory names when routines are presented with a name that
1722 * has no directory delimitors at all. So this routine will eventually
1725 static char * fixup_bare_dirnames(const char * name)
1727 if (decc_disable_to_vms_logname_translation) {
1734 * A little hack to get around a bug in some implemenation of remove()
1735 * that do not know how to delete a directory
1737 * Delete any file to which user has control access, regardless of whether
1738 * delete access is explicitly allowed.
1739 * Limitations: User must have write access to parent directory.
1740 * Does not block signals or ASTs; if interrupted in midstream
1741 * may leave file with an altered ACL.
1744 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1746 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1748 char *vmsname, *rspec;
1750 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1751 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1752 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1754 unsigned char myace$b_length;
1755 unsigned char myace$b_type;
1756 unsigned short int myace$w_flags;
1757 unsigned long int myace$l_access;
1758 unsigned long int myace$l_ident;
1759 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1760 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1761 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1763 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1764 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1765 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1766 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1767 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1768 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1770 /* Expand the input spec using RMS, since the CRTL remove() and
1771 * system services won't do this by themselves, so we may miss
1772 * a file "hiding" behind a logical name or search list. */
1773 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1774 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1776 if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1777 PerlMem_free(vmsname);
1781 if (decc_posix_compliant_pathnames) {
1782 /* In POSIX mode, we prefer to remove the UNIX name */
1784 remove_name = (char *)name;
1787 rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1788 if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1789 if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1790 PerlMem_free(rspec);
1791 PerlMem_free(vmsname);
1794 PerlMem_free(vmsname);
1795 remove_name = rspec;
1798 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1800 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1801 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1802 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1804 do_pathify_dirspec(name, remove_name, 0, NULL);
1805 if (!rmdir(remove_name)) {
1807 PerlMem_free(remove_name);
1808 PerlMem_free(rspec);
1809 return 0; /* Can we just get rid of it? */
1813 if (!rmdir(remove_name)) {
1814 PerlMem_free(rspec);
1815 return 0; /* Can we just get rid of it? */
1821 if (!remove(remove_name)) {
1822 PerlMem_free(rspec);
1823 return 0; /* Can we just get rid of it? */
1826 /* If not, can changing protections help? */
1827 if (vaxc$errno != RMS$_PRV) {
1828 PerlMem_free(rspec);
1832 /* No, so we get our own UIC to use as a rights identifier,
1833 * and the insert an ACE at the head of the ACL which allows us
1834 * to delete the file.
1836 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1837 fildsc.dsc$w_length = strlen(rspec);
1838 fildsc.dsc$a_pointer = rspec;
1840 newace.myace$l_ident = oldace.myace$l_ident;
1841 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1843 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1844 set_errno(ENOENT); break;
1846 set_errno(ENOTDIR); break;
1848 set_errno(ENODEV); break;
1849 case RMS$_SYN: case SS$_INVFILFOROP:
1850 set_errno(EINVAL); break;
1852 set_errno(EACCES); break;
1856 set_vaxc_errno(aclsts);
1857 PerlMem_free(rspec);
1860 /* Grab any existing ACEs with this identifier in case we fail */
1861 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1862 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1863 || fndsts == SS$_NOMOREACE ) {
1864 /* Add the new ACE . . . */
1865 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1868 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1870 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1871 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1872 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1874 do_pathify_dirspec(name, remove_name, 0, NULL);
1875 rmsts = rmdir(remove_name);
1876 PerlMem_free(remove_name);
1879 rmsts = rmdir(remove_name);
1883 rmsts = remove(remove_name);
1885 /* We blew it - dir with files in it, no write priv for
1886 * parent directory, etc. Put things back the way they were. */
1887 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1890 addlst[0].bufadr = &oldace;
1891 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1898 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1899 /* We just deleted it, so of course it's not there. Some versions of
1900 * VMS seem to return success on the unlock operation anyhow (after all
1901 * the unlock is successful), but others don't.
1903 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1904 if (aclsts & 1) aclsts = fndsts;
1905 if (!(aclsts & 1)) {
1907 set_vaxc_errno(aclsts);
1908 PerlMem_free(rspec);
1912 PerlMem_free(rspec);
1915 } /* end of kill_file() */
1919 /*{{{int do_rmdir(char *name)*/
1921 Perl_do_rmdir(pTHX_ const char *name)
1923 char dirfile[NAM$C_MAXRSS+1];
1927 if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1928 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1929 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1932 } /* end of do_rmdir */
1936 * Delete any file to which user has control access, regardless of whether
1937 * delete access is explicitly allowed.
1938 * Limitations: User must have write access to parent directory.
1939 * Does not block signals or ASTs; if interrupted in midstream
1940 * may leave file with an altered ACL.
1943 /*{{{int kill_file(char *name)*/
1945 Perl_kill_file(pTHX_ const char *name)
1947 char rspec[NAM$C_MAXRSS+1];
1949 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1950 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1951 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1953 unsigned char myace$b_length;
1954 unsigned char myace$b_type;
1955 unsigned short int myace$w_flags;
1956 unsigned long int myace$l_access;
1957 unsigned long int myace$l_ident;
1958 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1959 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1960 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1962 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1963 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1964 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1965 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1966 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1967 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1969 /* Expand the input spec using RMS, since the CRTL remove() and
1970 * system services won't do this by themselves, so we may miss
1971 * a file "hiding" behind a logical name or search list. */
1972 tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1973 if (tspec == NULL) return -1;
1974 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1975 /* If not, can changing protections help? */
1976 if (vaxc$errno != RMS$_PRV) return -1;
1978 /* No, so we get our own UIC to use as a rights identifier,
1979 * and the insert an ACE at the head of the ACL which allows us
1980 * to delete the file.
1982 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1983 fildsc.dsc$w_length = strlen(rspec);
1984 fildsc.dsc$a_pointer = rspec;
1986 newace.myace$l_ident = oldace.myace$l_ident;
1987 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1989 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1990 set_errno(ENOENT); break;
1992 set_errno(ENOTDIR); break;
1994 set_errno(ENODEV); break;
1995 case RMS$_SYN: case SS$_INVFILFOROP:
1996 set_errno(EINVAL); break;
1998 set_errno(EACCES); break;
2002 set_vaxc_errno(aclsts);
2005 /* Grab any existing ACEs with this identifier in case we fail */
2006 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2007 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2008 || fndsts == SS$_NOMOREACE ) {
2009 /* Add the new ACE . . . */
2010 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2012 if ((rmsts = remove(name))) {
2013 /* We blew it - dir with files in it, no write priv for
2014 * parent directory, etc. Put things back the way they were. */
2015 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2018 addlst[0].bufadr = &oldace;
2019 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2026 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2027 /* We just deleted it, so of course it's not there. Some versions of
2028 * VMS seem to return success on the unlock operation anyhow (after all
2029 * the unlock is successful), but others don't.
2031 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2032 if (aclsts & 1) aclsts = fndsts;
2033 if (!(aclsts & 1)) {
2035 set_vaxc_errno(aclsts);
2041 } /* end of kill_file() */
2045 /*{{{int my_mkdir(char *,Mode_t)*/
2047 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2049 STRLEN dirlen = strlen(dir);
2051 /* zero length string sometimes gives ACCVIO */
2052 if (dirlen == 0) return -1;
2054 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2055 * null file name/type. However, it's commonplace under Unix,
2056 * so we'll allow it for a gain in portability.
2058 if (dir[dirlen-1] == '/') {
2059 char *newdir = savepvn(dir,dirlen-1);
2060 int ret = mkdir(newdir,mode);
2064 else return mkdir(dir,mode);
2065 } /* end of my_mkdir */
2068 /*{{{int my_chdir(char *)*/
2070 Perl_my_chdir(pTHX_ const char *dir)
2072 STRLEN dirlen = strlen(dir);
2074 /* zero length string sometimes gives ACCVIO */
2075 if (dirlen == 0) return -1;
2078 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2079 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2080 * so that existing scripts do not need to be changed.
2083 while ((dirlen > 0) && (*dir1 == ' ')) {
2088 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2090 * null file name/type. However, it's commonplace under Unix,
2091 * so we'll allow it for a gain in portability.
2093 * - Preview- '/' will be valid soon on VMS
2095 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2096 char *newdir = savepvn(dir1,dirlen-1);
2097 int ret = chdir(newdir);
2101 else return chdir(dir1);
2102 } /* end of my_chdir */
2106 /*{{{FILE *my_tmpfile()*/
2113 if ((fp = tmpfile())) return fp;
2115 cp = PerlMem_malloc(L_tmpnam+24);
2116 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2118 if (decc_filename_unix_only == 0)
2119 strcpy(cp,"Sys$Scratch:");
2122 tmpnam(cp+strlen(cp));
2123 strcat(cp,".Perltmp");
2124 fp = fopen(cp,"w+","fop=dlt");
2131 #ifndef HOMEGROWN_POSIX_SIGNALS
2133 * The C RTL's sigaction fails to check for invalid signal numbers so we
2134 * help it out a bit. The docs are correct, but the actual routine doesn't
2135 * do what the docs say it will.
2137 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2139 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2140 struct sigaction* oact)
2142 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2143 SETERRNO(EINVAL, SS$_INVARG);
2146 return sigaction(sig, act, oact);
2151 #ifdef KILL_BY_SIGPRC
2152 #include <errnodef.h>
2154 /* We implement our own kill() using the undocumented system service
2155 sys$sigprc for one of two reasons:
2157 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2158 target process to do a sys$exit, which usually can't be handled
2159 gracefully...certainly not by Perl and the %SIG{} mechanism.
2161 2.) If the kill() in the CRTL can't be called from a signal
2162 handler without disappearing into the ether, i.e., the signal
2163 it purportedly sends is never trapped. Still true as of VMS 7.3.
2165 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2166 in the target process rather than calling sys$exit.
2168 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2169 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2170 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2171 with condition codes C$_SIG0+nsig*8, catching the exception on the
2172 target process and resignaling with appropriate arguments.
2174 But we don't have that VMS 7.0+ exception handler, so if you
2175 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2177 Also note that SIGTERM is listed in the docs as being "unimplemented",
2178 yet always seems to be signaled with a VMS condition code of 4 (and
2179 correctly handled for that code). So we hardwire it in.
2181 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2182 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2183 than signalling with an unrecognized (and unhandled by CRTL) code.
2186 #define _MY_SIG_MAX 28
2189 Perl_sig_to_vmscondition_int(int sig)
2191 static unsigned int sig_code[_MY_SIG_MAX+1] =
2194 SS$_HANGUP, /* 1 SIGHUP */
2195 SS$_CONTROLC, /* 2 SIGINT */
2196 SS$_CONTROLY, /* 3 SIGQUIT */
2197 SS$_RADRMOD, /* 4 SIGILL */
2198 SS$_BREAK, /* 5 SIGTRAP */
2199 SS$_OPCCUS, /* 6 SIGABRT */
2200 SS$_COMPAT, /* 7 SIGEMT */
2202 SS$_FLTOVF, /* 8 SIGFPE VAX */
2204 SS$_HPARITH, /* 8 SIGFPE AXP */
2206 SS$_ABORT, /* 9 SIGKILL */
2207 SS$_ACCVIO, /* 10 SIGBUS */
2208 SS$_ACCVIO, /* 11 SIGSEGV */
2209 SS$_BADPARAM, /* 12 SIGSYS */
2210 SS$_NOMBX, /* 13 SIGPIPE */
2211 SS$_ASTFLT, /* 14 SIGALRM */
2228 #if __VMS_VER >= 60200000
2229 static int initted = 0;
2232 sig_code[16] = C$_SIGUSR1;
2233 sig_code[17] = C$_SIGUSR2;
2234 #if __CRTL_VER >= 70000000
2235 sig_code[20] = C$_SIGCHLD;
2237 #if __CRTL_VER >= 70300000
2238 sig_code[28] = C$_SIGWINCH;
2243 if (sig < _SIG_MIN) return 0;
2244 if (sig > _MY_SIG_MAX) return 0;
2245 return sig_code[sig];
2249 Perl_sig_to_vmscondition(int sig)
2252 if (vms_debug_on_exception != 0)
2253 lib$signal(SS$_DEBUG);
2255 return Perl_sig_to_vmscondition_int(sig);
2260 Perl_my_kill(int pid, int sig)
2265 int sys$sigprc(unsigned int *pidadr,
2266 struct dsc$descriptor_s *prcname,
2269 /* sig 0 means validate the PID */
2270 /*------------------------------*/
2272 const unsigned long int jpicode = JPI$_PID;
2275 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2276 if ($VMS_STATUS_SUCCESS(status))
2279 case SS$_NOSUCHNODE:
2280 case SS$_UNREACHABLE:
2294 code = Perl_sig_to_vmscondition_int(sig);
2297 SETERRNO(EINVAL, SS$_BADPARAM);
2301 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2302 * signals are to be sent to multiple processes.
2303 * pid = 0 - all processes in group except ones that the system exempts
2304 * pid = -1 - all processes except ones that the system exempts
2305 * pid = -n - all processes in group (abs(n)) except ...
2306 * For now, just report as not supported.
2310 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2314 iss = sys$sigprc((unsigned int *)&pid,0,code);
2315 if (iss&1) return 0;
2319 set_errno(EPERM); break;
2321 case SS$_NOSUCHNODE:
2322 case SS$_UNREACHABLE:
2323 set_errno(ESRCH); break;
2325 set_errno(ENOMEM); break;
2330 set_vaxc_errno(iss);
2336 /* Routine to convert a VMS status code to a UNIX status code.
2337 ** More tricky than it appears because of conflicting conventions with
2340 ** VMS status codes are a bit mask, with the least significant bit set for
2343 ** Special UNIX status of EVMSERR indicates that no translation is currently
2344 ** available, and programs should check the VMS status code.
2346 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2350 #ifndef C_FACILITY_NO
2351 #define C_FACILITY_NO 0x350000
2354 #define DCL_IVVERB 0x38090
2357 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2365 /* Assume the best or the worst */
2366 if (vms_status & STS$M_SUCCESS)
2369 unix_status = EVMSERR;
2371 msg_status = vms_status & ~STS$M_CONTROL;
2373 facility = vms_status & STS$M_FAC_NO;
2374 fac_sp = vms_status & STS$M_FAC_SP;
2375 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2377 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2383 unix_status = EFAULT;
2385 case SS$_DEVOFFLINE:
2386 unix_status = EBUSY;
2389 unix_status = ENOTCONN;
2397 case SS$_INVFILFOROP:
2401 unix_status = EINVAL;
2403 case SS$_UNSUPPORTED:
2404 unix_status = ENOTSUP;
2409 unix_status = EACCES;
2411 case SS$_DEVICEFULL:
2412 unix_status = ENOSPC;
2415 unix_status = ENODEV;
2417 case SS$_NOSUCHFILE:
2418 case SS$_NOSUCHOBJECT:
2419 unix_status = ENOENT;
2421 case SS$_ABORT: /* Fatal case */
2422 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2423 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2424 unix_status = EINTR;
2427 unix_status = E2BIG;
2430 unix_status = ENOMEM;
2433 unix_status = EPERM;
2435 case SS$_NOSUCHNODE:
2436 case SS$_UNREACHABLE:
2437 unix_status = ESRCH;
2440 unix_status = ECHILD;
2443 if ((facility == 0) && (msg_no < 8)) {
2444 /* These are not real VMS status codes so assume that they are
2445 ** already UNIX status codes
2447 unix_status = msg_no;
2453 /* Translate a POSIX exit code to a UNIX exit code */
2454 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2455 unix_status = (msg_no & 0x07F8) >> 3;
2459 /* Documented traditional behavior for handling VMS child exits */
2460 /*--------------------------------------------------------------*/
2461 if (child_flag != 0) {
2463 /* Success / Informational return 0 */
2464 /*----------------------------------*/
2465 if (msg_no & STS$K_SUCCESS)
2468 /* Warning returns 1 */
2469 /*-------------------*/
2470 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2473 /* Everything else pass through the severity bits */
2474 /*------------------------------------------------*/
2475 return (msg_no & STS$M_SEVERITY);
2478 /* Normal VMS status to ERRNO mapping attempt */
2479 /*--------------------------------------------*/
2480 switch(msg_status) {
2481 /* case RMS$_EOF: */ /* End of File */
2482 case RMS$_FNF: /* File Not Found */
2483 case RMS$_DNF: /* Dir Not Found */
2484 unix_status = ENOENT;
2486 case RMS$_RNF: /* Record Not Found */
2487 unix_status = ESRCH;
2490 unix_status = ENOTDIR;
2493 unix_status = ENODEV;
2498 unix_status = EBADF;
2501 unix_status = EEXIST;
2505 case LIB$_INVSTRDES:
2507 case LIB$_NOSUCHSYM:
2508 case LIB$_INVSYMNAM:
2510 unix_status = EINVAL;
2516 unix_status = E2BIG;
2518 case RMS$_PRV: /* No privilege */
2519 case RMS$_ACC: /* ACP file access failed */
2520 case RMS$_WLK: /* Device write locked */
2521 unix_status = EACCES;
2523 /* case RMS$_NMF: */ /* No more files */
2531 /* Try to guess at what VMS error status should go with a UNIX errno
2532 * value. This is hard to do as there could be many possible VMS
2533 * error statuses that caused the errno value to be set.
2536 int Perl_unix_status_to_vms(int unix_status)
2538 int test_unix_status;
2540 /* Trivial cases first */
2541 /*---------------------*/
2542 if (unix_status == EVMSERR)
2545 /* Is vaxc$errno sane? */
2546 /*---------------------*/
2547 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2548 if (test_unix_status == unix_status)
2551 /* If way out of range, must be VMS code already */
2552 /*-----------------------------------------------*/
2553 if (unix_status > EVMSERR)
2556 /* If out of range, punt */
2557 /*-----------------------*/
2558 if (unix_status > __ERRNO_MAX)
2562 /* Ok, now we have to do it the hard way. */
2563 /*----------------------------------------*/
2564 switch(unix_status) {
2565 case 0: return SS$_NORMAL;
2566 case EPERM: return SS$_NOPRIV;
2567 case ENOENT: return SS$_NOSUCHOBJECT;
2568 case ESRCH: return SS$_UNREACHABLE;
2569 case EINTR: return SS$_ABORT;
2572 case E2BIG: return SS$_BUFFEROVF;
2574 case EBADF: return RMS$_IFI;
2575 case ECHILD: return SS$_NONEXPR;
2577 case ENOMEM: return SS$_INSFMEM;
2578 case EACCES: return SS$_FILACCERR;
2579 case EFAULT: return SS$_ACCVIO;
2581 case EBUSY: return SS$_DEVOFFLINE;
2582 case EEXIST: return RMS$_FEX;
2584 case ENODEV: return SS$_NOSUCHDEV;
2585 case ENOTDIR: return RMS$_DIR;
2587 case EINVAL: return SS$_INVARG;
2593 case ENOSPC: return SS$_DEVICEFULL;
2594 case ESPIPE: return LIB$_INVARG;
2599 case ERANGE: return LIB$_INVARG;
2600 /* case EWOULDBLOCK */
2601 /* case EINPROGRESS */
2604 /* case EDESTADDRREQ */
2606 /* case EPROTOTYPE */
2607 /* case ENOPROTOOPT */
2608 /* case EPROTONOSUPPORT */
2609 /* case ESOCKTNOSUPPORT */
2610 /* case EOPNOTSUPP */
2611 /* case EPFNOSUPPORT */
2612 /* case EAFNOSUPPORT */
2613 /* case EADDRINUSE */
2614 /* case EADDRNOTAVAIL */
2616 /* case ENETUNREACH */
2617 /* case ENETRESET */
2618 /* case ECONNABORTED */
2619 /* case ECONNRESET */
2622 case ENOTCONN: return SS$_CLEARED;
2623 /* case ESHUTDOWN */
2624 /* case ETOOMANYREFS */
2625 /* case ETIMEDOUT */
2626 /* case ECONNREFUSED */
2628 /* case ENAMETOOLONG */
2629 /* case EHOSTDOWN */
2630 /* case EHOSTUNREACH */
2631 /* case ENOTEMPTY */
2643 /* case ECANCELED */
2647 return SS$_UNSUPPORTED;
2653 /* case EABANDONED */
2655 return SS$_ABORT; /* punt */
2658 return SS$_ABORT; /* Should not get here */
2662 /* default piping mailbox size */
2663 #define PERL_BUFSIZ 512
2667 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2669 unsigned long int mbxbufsiz;
2670 static unsigned long int syssize = 0;
2671 unsigned long int dviitm = DVI$_DEVNAM;
2672 char csize[LNM$C_NAMLENGTH+1];
2676 unsigned long syiitm = SYI$_MAXBUF;
2678 * Get the SYSGEN parameter MAXBUF
2680 * If the logical 'PERL_MBX_SIZE' is defined
2681 * use the value of the logical instead of PERL_BUFSIZ, but
2682 * keep the size between 128 and MAXBUF.
2685 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2688 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2689 mbxbufsiz = atoi(csize);
2691 mbxbufsiz = PERL_BUFSIZ;
2693 if (mbxbufsiz < 128) mbxbufsiz = 128;
2694 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2696 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2698 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2699 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2701 } /* end of create_mbx() */
2704 /*{{{ my_popen and my_pclose*/
2706 typedef struct _iosb IOSB;
2707 typedef struct _iosb* pIOSB;
2708 typedef struct _pipe Pipe;
2709 typedef struct _pipe* pPipe;
2710 typedef struct pipe_details Info;
2711 typedef struct pipe_details* pInfo;
2712 typedef struct _srqp RQE;
2713 typedef struct _srqp* pRQE;
2714 typedef struct _tochildbuf CBuf;
2715 typedef struct _tochildbuf* pCBuf;
2718 unsigned short status;
2719 unsigned short count;
2720 unsigned long dvispec;
2723 #pragma member_alignment save
2724 #pragma nomember_alignment quadword
2725 struct _srqp { /* VMS self-relative queue entry */
2726 unsigned long qptr[2];
2728 #pragma member_alignment restore
2729 static RQE RQE_ZERO = {0,0};
2731 struct _tochildbuf {
2734 unsigned short size;
2742 unsigned short chan_in;
2743 unsigned short chan_out;
2745 unsigned int bufsize;
2757 #if defined(PERL_IMPLICIT_CONTEXT)
2758 void *thx; /* Either a thread or an interpreter */
2759 /* pointer, depending on how we're built */
2767 PerlIO *fp; /* file pointer to pipe mailbox */
2768 int useFILE; /* using stdio, not perlio */
2769 int pid; /* PID of subprocess */
2770 int mode; /* == 'r' if pipe open for reading */
2771 int done; /* subprocess has completed */
2772 int waiting; /* waiting for completion/closure */
2773 int closing; /* my_pclose is closing this pipe */
2774 unsigned long completion; /* termination status of subprocess */
2775 pPipe in; /* pipe in to sub */
2776 pPipe out; /* pipe out of sub */
2777 pPipe err; /* pipe of sub's sys$error */
2778 int in_done; /* true when in pipe finished */
2781 unsigned short xchan; /* channel to debug xterm */
2782 unsigned short xchan_valid; /* channel is assigned */
2785 struct exit_control_block
2787 struct exit_control_block *flink;
2788 unsigned long int (*exit_routine)();
2789 unsigned long int arg_count;
2790 unsigned long int *status_address;
2791 unsigned long int exit_status;
2794 typedef struct _closed_pipes Xpipe;
2795 typedef struct _closed_pipes* pXpipe;
2797 struct _closed_pipes {
2798 int pid; /* PID of subprocess */
2799 unsigned long completion; /* termination status of subprocess */
2801 #define NKEEPCLOSED 50
2802 static Xpipe closed_list[NKEEPCLOSED];
2803 static int closed_index = 0;
2804 static int closed_num = 0;
2806 #define RETRY_DELAY "0 ::0.20"
2807 #define MAX_RETRY 50
2809 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2810 static unsigned long mypid;
2811 static unsigned long delaytime[2];
2813 static pInfo open_pipes = NULL;
2814 static $DESCRIPTOR(nl_desc, "NL:");
2816 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2820 static unsigned long int
2821 pipe_exit_routine(pTHX)
2824 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2825 int sts, did_stuff, need_eof, j;
2828 flush any pending i/o
2834 PerlIO_flush(info->fp); /* first, flush data */
2836 fflush((FILE *)info->fp);
2842 next we try sending an EOF...ignore if doesn't work, make sure we
2850 _ckvmssts_noperl(sys$setast(0));
2851 if (info->in && !info->in->shut_on_empty) {
2852 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2857 _ckvmssts_noperl(sys$setast(1));
2861 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2863 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2868 _ckvmssts_noperl(sys$setast(0));
2869 if (info->waiting && info->done)
2871 nwait += info->waiting;
2872 _ckvmssts_noperl(sys$setast(1));
2882 _ckvmssts_noperl(sys$setast(0));
2883 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2884 sts = sys$forcex(&info->pid,0,&abort);
2885 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2888 _ckvmssts_noperl(sys$setast(1));
2892 /* again, wait for effect */
2894 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2899 _ckvmssts_noperl(sys$setast(0));
2900 if (info->waiting && info->done)
2902 nwait += info->waiting;
2903 _ckvmssts_noperl(sys$setast(1));
2912 _ckvmssts_noperl(sys$setast(0));
2913 if (!info->done) { /* We tried to be nice . . . */
2914 sts = sys$delprc(&info->pid,0);
2915 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2916 info->done = 1; /* sys$delprc is as done as we're going to get. */
2918 _ckvmssts_noperl(sys$setast(1));
2923 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2924 else if (!(sts & 1)) retsts = sts;
2929 static struct exit_control_block pipe_exitblock =
2930 {(struct exit_control_block *) 0,
2931 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2933 static void pipe_mbxtofd_ast(pPipe p);
2934 static void pipe_tochild1_ast(pPipe p);
2935 static void pipe_tochild2_ast(pPipe p);
2938 popen_completion_ast(pInfo info)
2940 pInfo i = open_pipes;
2945 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2946 closed_list[closed_index].pid = info->pid;
2947 closed_list[closed_index].completion = info->completion;
2949 if (closed_index == NKEEPCLOSED)
2954 if (i == info) break;
2957 if (!i) return; /* unlinked, probably freed too */
2962 Writing to subprocess ...
2963 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2965 chan_out may be waiting for "done" flag, or hung waiting
2966 for i/o completion to child...cancel the i/o. This will
2967 put it into "snarf mode" (done but no EOF yet) that discards
2970 Output from subprocess (stdout, stderr) needs to be flushed and
2971 shut down. We try sending an EOF, but if the mbx is full the pipe
2972 routine should still catch the "shut_on_empty" flag, telling it to
2973 use immediate-style reads so that "mbx empty" -> EOF.
2977 if (info->in && !info->in_done) { /* only for mode=w */
2978 if (info->in->shut_on_empty && info->in->need_wake) {
2979 info->in->need_wake = FALSE;
2980 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2982 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2986 if (info->out && !info->out_done) { /* were we also piping output? */
2987 info->out->shut_on_empty = TRUE;
2988 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2989 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2990 _ckvmssts_noperl(iss);
2993 if (info->err && !info->err_done) { /* we were piping stderr */
2994 info->err->shut_on_empty = TRUE;
2995 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2996 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2997 _ckvmssts_noperl(iss);
2999 _ckvmssts_noperl(sys$setef(pipe_ef));
3003 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3004 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3007 we actually differ from vmstrnenv since we use this to
3008 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3009 are pointing to the same thing
3012 static unsigned short
3013 popen_translate(pTHX_ char *logical, char *result)
3016 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3017 $DESCRIPTOR(d_log,"");
3019 unsigned short length;
3020 unsigned short code;
3022 unsigned short *retlenaddr;
3024 unsigned short l, ifi;
3026 d_log.dsc$a_pointer = logical;
3027 d_log.dsc$w_length = strlen(logical);
3029 itmlst[0].code = LNM$_STRING;
3030 itmlst[0].length = 255;
3031 itmlst[0].buffer_addr = result;
3032 itmlst[0].retlenaddr = &l;
3035 itmlst[1].length = 0;
3036 itmlst[1].buffer_addr = 0;
3037 itmlst[1].retlenaddr = 0;
3039 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3040 if (iss == SS$_NOLOGNAM) {
3044 if (!(iss&1)) lib$signal(iss);
3047 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3048 strip it off and return the ifi, if any
3051 if (result[0] == 0x1b && result[1] == 0x00) {
3052 memmove(&ifi,result+2,2);
3053 strcpy(result,result+4);
3055 return ifi; /* this is the RMS internal file id */
3058 static void pipe_infromchild_ast(pPipe p);
3061 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3062 inside an AST routine without worrying about reentrancy and which Perl
3063 memory allocator is being used.
3065 We read data and queue up the buffers, then spit them out one at a
3066 time to the output mailbox when the output mailbox is ready for one.
3069 #define INITIAL_TOCHILDQUEUE 2
3072 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3076 char mbx1[64], mbx2[64];
3077 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3078 DSC$K_CLASS_S, mbx1},
3079 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3080 DSC$K_CLASS_S, mbx2};
3081 unsigned int dviitm = DVI$_DEVBUFSIZ;
3085 _ckvmssts(lib$get_vm(&n, &p));
3087 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3088 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3089 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3092 p->shut_on_empty = FALSE;
3093 p->need_wake = FALSE;
3096 p->iosb.status = SS$_NORMAL;
3097 p->iosb2.status = SS$_NORMAL;
3103 #ifdef PERL_IMPLICIT_CONTEXT
3107 n = sizeof(CBuf) + p->bufsize;
3109 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3110 _ckvmssts(lib$get_vm(&n, &b));
3111 b->buf = (char *) b + sizeof(CBuf);
3112 _ckvmssts(lib$insqhi(b, &p->free));
3115 pipe_tochild2_ast(p);
3116 pipe_tochild1_ast(p);
3122 /* reads the MBX Perl is writing, and queues */
3125 pipe_tochild1_ast(pPipe p)
3128 int iss = p->iosb.status;
3129 int eof = (iss == SS$_ENDOFFILE);
3131 #ifdef PERL_IMPLICIT_CONTEXT
3137 p->shut_on_empty = TRUE;
3139 _ckvmssts(sys$dassgn(p->chan_in));
3145 b->size = p->iosb.count;
3146 _ckvmssts(sts = lib$insqhi(b, &p->wait));
3148 p->need_wake = FALSE;
3149 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3152 p->retry = 1; /* initial call */
3155 if (eof) { /* flush the free queue, return when done */
3156 int n = sizeof(CBuf) + p->bufsize;
3158 iss = lib$remqti(&p->free, &b);
3159 if (iss == LIB$_QUEWASEMP) return;
3161 _ckvmssts(lib$free_vm(&n, &b));
3165 iss = lib$remqti(&p->free, &b);
3166 if (iss == LIB$_QUEWASEMP) {
3167 int n = sizeof(CBuf) + p->bufsize;
3168 _ckvmssts(lib$get_vm(&n, &b));
3169 b->buf = (char *) b + sizeof(CBuf);
3175 iss = sys$qio(0,p->chan_in,
3176 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3178 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3179 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3184 /* writes queued buffers to output, waits for each to complete before
3188 pipe_tochild2_ast(pPipe p)
3191 int iss = p->iosb2.status;
3192 int n = sizeof(CBuf) + p->bufsize;
3193 int done = (p->info && p->info->done) ||
3194 iss == SS$_CANCEL || iss == SS$_ABORT;
3195 #if defined(PERL_IMPLICIT_CONTEXT)
3200 if (p->type) { /* type=1 has old buffer, dispose */
3201 if (p->shut_on_empty) {
3202 _ckvmssts(lib$free_vm(&n, &b));
3204 _ckvmssts(lib$insqhi(b, &p->free));
3209 iss = lib$remqti(&p->wait, &b);
3210 if (iss == LIB$_QUEWASEMP) {
3211 if (p->shut_on_empty) {
3213 _ckvmssts(sys$dassgn(p->chan_out));
3214 *p->pipe_done = TRUE;
3215 _ckvmssts(sys$setef(pipe_ef));
3217 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3218 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3222 p->need_wake = TRUE;
3232 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3233 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3235 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3236 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3245 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3248 char mbx1[64], mbx2[64];
3249 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3250 DSC$K_CLASS_S, mbx1},
3251 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3252 DSC$K_CLASS_S, mbx2};
3253 unsigned int dviitm = DVI$_DEVBUFSIZ;
3255 int n = sizeof(Pipe);
3256 _ckvmssts(lib$get_vm(&n, &p));
3257 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3258 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3260 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3261 n = p->bufsize * sizeof(char);
3262 _ckvmssts(lib$get_vm(&n, &p->buf));
3263 p->shut_on_empty = FALSE;
3266 p->iosb.status = SS$_NORMAL;
3267 #if defined(PERL_IMPLICIT_CONTEXT)
3270 pipe_infromchild_ast(p);
3278 pipe_infromchild_ast(pPipe p)
3280 int iss = p->iosb.status;
3281 int eof = (iss == SS$_ENDOFFILE);
3282 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3283 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3284 #if defined(PERL_IMPLICIT_CONTEXT)
3288 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3289 _ckvmssts(sys$dassgn(p->chan_out));
3294 input shutdown if EOF from self (done or shut_on_empty)
3295 output shutdown if closing flag set (my_pclose)
3296 send data/eof from child or eof from self
3297 otherwise, re-read (snarf of data from child)
3302 if (myeof && p->chan_in) { /* input shutdown */
3303 _ckvmssts(sys$dassgn(p->chan_in));
3308 if (myeof || kideof) { /* pass EOF to parent */
3309 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3310 pipe_infromchild_ast, p,
3313 } else if (eof) { /* eat EOF --- fall through to read*/
3315 } else { /* transmit data */
3316 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3317 pipe_infromchild_ast,p,
3318 p->buf, p->iosb.count, 0, 0, 0, 0));
3324 /* everything shut? flag as done */
3326 if (!p->chan_in && !p->chan_out) {
3327 *p->pipe_done = TRUE;
3328 _ckvmssts(sys$setef(pipe_ef));
3332 /* write completed (or read, if snarfing from child)
3333 if still have input active,
3334 queue read...immediate mode if shut_on_empty so we get EOF if empty
3336 check if Perl reading, generate EOFs as needed
3342 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3343 pipe_infromchild_ast,p,
3344 p->buf, p->bufsize, 0, 0, 0, 0);
3345 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3347 } else { /* send EOFs for extra reads */
3348 p->iosb.status = SS$_ENDOFFILE;
3349 p->iosb.dvispec = 0;
3350 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3352 pipe_infromchild_ast, p, 0, 0, 0, 0));
3358 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3362 unsigned long dviitm = DVI$_DEVBUFSIZ;
3364 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3365 DSC$K_CLASS_S, mbx};
3366 int n = sizeof(Pipe);
3368 /* things like terminals and mbx's don't need this filter */
3369 if (fd && fstat(fd,&s) == 0) {
3370 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3372 unsigned short dev_len;
3373 struct dsc$descriptor_s d_dev;
3375 struct item_list_3 items[3];
3377 unsigned short dvi_iosb[4];
3379 cptr = getname(fd, out, 1);
3380 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3381 d_dev.dsc$a_pointer = out;
3382 d_dev.dsc$w_length = strlen(out);
3383 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3384 d_dev.dsc$b_class = DSC$K_CLASS_S;
3387 items[0].code = DVI$_DEVCHAR;
3388 items[0].bufadr = &devchar;
3389 items[0].retadr = NULL;
3391 items[1].code = DVI$_FULLDEVNAM;
3392 items[1].bufadr = device;
3393 items[1].retadr = &dev_len;
3397 status = sys$getdviw
3398 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3400 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3401 device[dev_len] = 0;
3403 if (!(devchar & DEV$M_DIR)) {
3404 strcpy(out, device);
3410 _ckvmssts(lib$get_vm(&n, &p));
3411 p->fd_out = dup(fd);
3412 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3413 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3414 n = (p->bufsize+1) * sizeof(char);
3415 _ckvmssts(lib$get_vm(&n, &p->buf));
3416 p->shut_on_empty = FALSE;
3421 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3422 pipe_mbxtofd_ast, p,
3423 p->buf, p->bufsize, 0, 0, 0, 0));
3429 pipe_mbxtofd_ast(pPipe p)
3431 int iss = p->iosb.status;
3432 int done = p->info->done;
3434 int eof = (iss == SS$_ENDOFFILE);
3435 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3436 int err = !(iss&1) && !eof;
3437 #if defined(PERL_IMPLICIT_CONTEXT)
3441 if (done && myeof) { /* end piping */
3443 sys$dassgn(p->chan_in);
3444 *p->pipe_done = TRUE;
3445 _ckvmssts(sys$setef(pipe_ef));
3449 if (!err && !eof) { /* good data to send to file */
3450 p->buf[p->iosb.count] = '\n';
3451 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3454 if (p->retry < MAX_RETRY) {
3455 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3465 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3466 pipe_mbxtofd_ast, p,
3467 p->buf, p->bufsize, 0, 0, 0, 0);
3468 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3473 typedef struct _pipeloc PLOC;
3474 typedef struct _pipeloc* pPLOC;
3478 char dir[NAM$C_MAXRSS+1];
3480 static pPLOC head_PLOC = 0;
3483 free_pipelocs(pTHX_ void *head)
3486 pPLOC *pHead = (pPLOC *)head;
3498 store_pipelocs(pTHX)
3507 char temp[NAM$C_MAXRSS+1];
3511 free_pipelocs(aTHX_ &head_PLOC);
3513 /* the . directory from @INC comes last */
3515 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3516 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3517 p->next = head_PLOC;
3519 strcpy(p->dir,"./");
3521 /* get the directory from $^X */
3523 unixdir = PerlMem_malloc(VMS_MAXRSS);
3524 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3526 #ifdef PERL_IMPLICIT_CONTEXT
3527 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3529 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3531 strcpy(temp, PL_origargv[0]);
3532 x = strrchr(temp,']');
3534 x = strrchr(temp,'>');
3536 /* It could be a UNIX path */
3537 x = strrchr(temp,'/');
3543 /* Got a bare name, so use default directory */
3548 if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3549 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3550 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3551 p->next = head_PLOC;
3553 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3554 p->dir[NAM$C_MAXRSS] = '\0';
3558 /* reverse order of @INC entries, skip "." since entered above */
3560 #ifdef PERL_IMPLICIT_CONTEXT
3563 if (PL_incgv) av = GvAVn(PL_incgv);
3565 for (i = 0; av && i <= AvFILL(av); i++) {
3566 dirsv = *av_fetch(av,i,TRUE);
3568 if (SvROK(dirsv)) continue;
3569 dir = SvPVx(dirsv,n_a);
3570 if (strcmp(dir,".") == 0) continue;
3571 if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3574 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3575 p->next = head_PLOC;
3577 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3578 p->dir[NAM$C_MAXRSS] = '\0';
3581 /* most likely spot (ARCHLIB) put first in the list */
3584 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3585 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3586 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3587 p->next = head_PLOC;
3589 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3590 p->dir[NAM$C_MAXRSS] = '\0';
3593 PerlMem_free(unixdir);
3597 Perl_cando_by_name_int
3598 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3599 #if !defined(PERL_IMPLICIT_CONTEXT)
3600 #define cando_by_name_int Perl_cando_by_name_int
3602 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3608 static int vmspipe_file_status = 0;
3609 static char vmspipe_file[NAM$C_MAXRSS+1];
3611 /* already found? Check and use ... need read+execute permission */
3613 if (vmspipe_file_status == 1) {
3614 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3615 && cando_by_name_int
3616 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3617 return vmspipe_file;
3619 vmspipe_file_status = 0;
3622 /* scan through stored @INC, $^X */
3624 if (vmspipe_file_status == 0) {
3625 char file[NAM$C_MAXRSS+1];
3626 pPLOC p = head_PLOC;
3631 strcpy(file, p->dir);
3632 dirlen = strlen(file);
3633 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3634 file[NAM$C_MAXRSS] = '\0';
3637 exp_res = do_rmsexpand
3638 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3639 if (!exp_res) continue;
3641 if (cando_by_name_int
3642 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3643 && cando_by_name_int
3644 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3645 vmspipe_file_status = 1;
3646 return vmspipe_file;
3649 vmspipe_file_status = -1; /* failed, use tempfiles */
3656 vmspipe_tempfile(pTHX)
3658 char file[NAM$C_MAXRSS+1];
3660 static int index = 0;
3664 /* create a tempfile */
3666 /* we can't go from W, shr=get to R, shr=get without
3667 an intermediate vulnerable state, so don't bother trying...
3669 and lib$spawn doesn't shr=put, so have to close the write
3671 So... match up the creation date/time and the FID to
3672 make sure we're dealing with the same file
3677 if (!decc_filename_unix_only) {
3678 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3679 fp = fopen(file,"w");
3681 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3682 fp = fopen(file,"w");
3684 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3685 fp = fopen(file,"w");
3690 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3691 fp = fopen(file,"w");
3693 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3694 fp = fopen(file,"w");
3696 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3697 fp = fopen(file,"w");
3701 if (!fp) return 0; /* we're hosed */
3703 fprintf(fp,"$! 'f$verify(0)'\n");
3704 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3705 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3706 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3707 fprintf(fp,"$ perl_on = \"set noon\"\n");
3708 fprintf(fp,"$ perl_exit = \"exit\"\n");
3709 fprintf(fp,"$ perl_del = \"delete\"\n");
3710 fprintf(fp,"$ pif = \"if\"\n");
3711 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3712 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3713 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3714 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3715 fprintf(fp,"$! --- build command line to get max possible length\n");
3716 fprintf(fp,"$c=perl_popen_cmd0\n");
3717 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3718 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3719 fprintf(fp,"$x=perl_popen_cmd3\n");
3720 fprintf(fp,"$c=c+x\n");
3721 fprintf(fp,"$ perl_on\n");
3722 fprintf(fp,"$ 'c'\n");
3723 fprintf(fp,"$ perl_status = $STATUS\n");
3724 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3725 fprintf(fp,"$ perl_exit 'perl_status'\n");
3728 fgetname(fp, file, 1);
3729 fstat(fileno(fp), (struct stat *)&s0);
3732 if (decc_filename_unix_only)
3733 do_tounixspec(file, file, 0, NULL);
3734 fp = fopen(file,"r","shr=get");
3736 fstat(fileno(fp), (struct stat *)&s1);
3738 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3739 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3748 #ifdef USE_VMS_DECTERM
3750 static int vms_is_syscommand_xterm(void)
3752 const static struct dsc$descriptor_s syscommand_dsc =
3753 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3755 const static struct dsc$descriptor_s decwdisplay_dsc =
3756 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3758 struct item_list_3 items[2];
3759 unsigned short dvi_iosb[4];
3760 unsigned long devchar;
3761 unsigned long devclass;
3764 /* Very simple check to guess if sys$command is a decterm? */
3765 /* First see if the DECW$DISPLAY: device exists */
3767 items[0].code = DVI$_DEVCHAR;
3768 items[0].bufadr = &devchar;
3769 items[0].retadr = NULL;
3773 status = sys$getdviw
3774 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3776 if ($VMS_STATUS_SUCCESS(status)) {
3777 status = dvi_iosb[0];
3780 if (!$VMS_STATUS_SUCCESS(status)) {
3781 SETERRNO(EVMSERR, status);
3785 /* If it does, then for now assume that we are on a workstation */
3786 /* Now verify that SYS$COMMAND is a terminal */
3787 /* for creating the debugger DECTerm */
3790 items[0].code = DVI$_DEVCLASS;
3791 items[0].bufadr = &devclass;
3792 items[0].retadr = NULL;
3796 status = sys$getdviw
3797 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3799 if ($VMS_STATUS_SUCCESS(status)) {
3800 status = dvi_iosb[0];
3803 if (!$VMS_STATUS_SUCCESS(status)) {
3804 SETERRNO(EVMSERR, status);
3808 if (devclass == DC$_TERM) {
3815 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3816 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3821 char device_name[65];
3822 unsigned short device_name_len;
3823 struct dsc$descriptor_s customization_dsc;
3824 struct dsc$descriptor_s device_name_dsc;
3827 char customization[200];
3831 unsigned short p_chan;
3833 unsigned short iosb[4];
3834 struct item_list_3 items[2];
3835 const char * cust_str =
3836 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3837 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3838 DSC$K_CLASS_S, mbx1};
3840 ret_char = strstr(cmd," xterm ");
3841 if (ret_char == NULL)
3843 cptr = ret_char + 7;
3844 ret_char = strstr(cmd,"tty");
3845 if (ret_char == NULL)
3847 ret_char = strstr(cmd,"sleep");
3848 if (ret_char == NULL)
3851 /* Are we on a workstation? */
3852 /* to do: capture the rows / columns and pass their properties */
3853 ret_stat = vms_is_syscommand_xterm();
3857 /* Make the title: */
3858 ret_char = strstr(cptr,"-title");
3859 if (ret_char != NULL) {
3860 while ((*cptr != 0) && (*cptr != '\"')) {
3866 while ((*cptr != 0) && (*cptr != '\"')) {
3879 strcpy(title,"Perl Debug DECTerm");
3881 sprintf(customization, cust_str, title);
3883 customization_dsc.dsc$a_pointer = customization;
3884 customization_dsc.dsc$w_length = strlen(customization);
3885 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3886 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3888 device_name_dsc.dsc$a_pointer = device_name;
3889 device_name_dsc.dsc$w_length = sizeof device_name -1;
3890 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3891 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3893 device_name_len = 0;
3895 /* Try to create the window */
3896 status = decw$term_port
3905 if (!$VMS_STATUS_SUCCESS(status)) {
3906 SETERRNO(EVMSERR, status);
3910 device_name[device_name_len] = '\0';
3912 /* Need to set this up to look like a pipe for cleanup */
3914 status = lib$get_vm(&n, &info);
3915 if (!$VMS_STATUS_SUCCESS(status)) {
3916 SETERRNO(ENOMEM, status);
3922 info->completion = 0;
3923 info->closing = FALSE;
3930 info->in_done = TRUE;
3931 info->out_done = TRUE;
3932 info->err_done = TRUE;
3934 /* Assign a channel on this so that it will persist, and not login */
3935 /* We stash this channel in the info structure for reference. */
3936 /* The created xterm self destructs when the last channel is removed */
3937 /* and it appears that perl5db.pl (perl debugger) does this routinely */
3938 /* So leave this assigned. */
3939 device_name_dsc.dsc$w_length = device_name_len;
3940 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
3941 if (!$VMS_STATUS_SUCCESS(status)) {
3942 SETERRNO(EVMSERR, status);
3945 info->xchan_valid = 1;
3947 /* Now create a mailbox to be read by the application */
3949 create_mbx(aTHX_ &p_chan, &d_mbx1);
3951 /* write the name of the created terminal to the mailbox */
3952 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
3953 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
3955 if (!$VMS_STATUS_SUCCESS(status)) {
3956 SETERRNO(EVMSERR, status);
3960 info->fp = PerlIO_open(mbx1, mode);
3962 /* Done with this channel */
3965 /* If any errors, then clean up */
3968 _ckvmssts(lib$free_vm(&n, &info));
3978 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3980 static int handler_set_up = FALSE;
3981 unsigned long int sts, flags = CLI$M_NOWAIT;
3982 /* The use of a GLOBAL table (as was done previously) rendered
3983 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3984 * environment. Hence we've switched to LOCAL symbol table.
3986 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3988 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3989 char *in, *out, *err, mbx[512];
3991 char tfilebuf[NAM$C_MAXRSS+1];
3993 char cmd_sym_name[20];
3994 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3995 DSC$K_CLASS_S, symbol};
3996 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3998 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3999 DSC$K_CLASS_S, cmd_sym_name};
4000 struct dsc$descriptor_s *vmscmd;
4001 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4002 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4003 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4005 #ifdef USE_VMS_DECTERM
4006 /* Check here for Xterm create request. This means looking for
4007 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4008 * is possible to create an xterm.
4010 if (*in_mode == 'r') {
4013 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4014 if (xterm_fd != Nullfp)
4019 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4021 /* once-per-program initialization...
4022 note that the SETAST calls and the dual test of pipe_ef
4023 makes sure that only the FIRST thread through here does
4024 the initialization...all other threads wait until it's
4027 Yeah, uglier than a pthread call, it's got all the stuff inline
4028 rather than in a separate routine.
4032 _ckvmssts(sys$setast(0));
4034 unsigned long int pidcode = JPI$_PID;
4035 $DESCRIPTOR(d_delay, RETRY_DELAY);
4036 _ckvmssts(lib$get_ef(&pipe_ef));
4037 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4038 _ckvmssts(sys$bintim(&d_delay, delaytime));
4040 if (!handler_set_up) {
4041 _ckvmssts(sys$dclexh(&pipe_exitblock));
4042 handler_set_up = TRUE;
4044 _ckvmssts(sys$setast(1));
4047 /* see if we can find a VMSPIPE.COM */
4050 vmspipe = find_vmspipe(aTHX);
4052 strcpy(tfilebuf+1,vmspipe);
4053 } else { /* uh, oh...we're in tempfile hell */
4054 tpipe = vmspipe_tempfile(aTHX);
4055 if (!tpipe) { /* a fish popular in Boston */
4056 if (ckWARN(WARN_PIPE)) {
4057 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4061 fgetname(tpipe,tfilebuf+1,1);
4063 vmspipedsc.dsc$a_pointer = tfilebuf;
4064 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4066 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4069 case RMS$_FNF: case RMS$_DNF:
4070 set_errno(ENOENT); break;
4072 set_errno(ENOTDIR); break;
4074 set_errno(ENODEV); break;
4076 set_errno(EACCES); break;
4078 set_errno(EINVAL); break;
4079 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4080 set_errno(E2BIG); break;
4081 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4082 _ckvmssts(sts); /* fall through */
4083 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4086 set_vaxc_errno(sts);
4087 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4088 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4094 _ckvmssts(lib$get_vm(&n, &info));
4096 strcpy(mode,in_mode);
4099 info->completion = 0;
4100 info->closing = FALSE;
4107 info->in_done = TRUE;
4108 info->out_done = TRUE;
4109 info->err_done = TRUE;
4111 info->xchan_valid = 0;
4113 in = PerlMem_malloc(VMS_MAXRSS);
4114 if (in == NULL) _ckvmssts(SS$_INSFMEM);
4115 out = PerlMem_malloc(VMS_MAXRSS);
4116 if (out == NULL) _ckvmssts(SS$_INSFMEM);
4117 err = PerlMem_malloc(VMS_MAXRSS);
4118 if (err == NULL) _ckvmssts(SS$_INSFMEM);
4120 in[0] = out[0] = err[0] = '\0';
4122 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4126 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4131 if (*mode == 'r') { /* piping from subroutine */
4133 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4135 info->out->pipe_done = &info->out_done;
4136 info->out_done = FALSE;
4137 info->out->info = info;
4139 if (!info->useFILE) {
4140 info->fp = PerlIO_open(mbx, mode);
4142 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4143 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4146 if (!info->fp && info->out) {
4147 sys$cancel(info->out->chan_out);
4149 while (!info->out_done) {
4151 _ckvmssts(sys$setast(0));
4152 done = info->out_done;
4153 if (!done) _ckvmssts(sys$clref(pipe_ef));
4154 _ckvmssts(sys$setast(1));
4155 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4158 if (info->out->buf) {
4159 n = info->out->bufsize * sizeof(char);
4160 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4163 _ckvmssts(lib$free_vm(&n, &info->out));
4165 _ckvmssts(lib$free_vm(&n, &info));
4170 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4172 info->err->pipe_done = &info->err_done;
4173 info->err_done = FALSE;
4174 info->err->info = info;
4177 } else if (*mode == 'w') { /* piping to subroutine */
4179 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4181 info->out->pipe_done = &info->out_done;
4182 info->out_done = FALSE;
4183 info->out->info = info;
4186 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4188 info->err->pipe_done = &info->err_done;
4189 info->err_done = FALSE;
4190 info->err->info = info;
4193 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4194 if (!info->useFILE) {
4195 info->fp = PerlIO_open(mbx, mode);
4197 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4198 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4202 info->in->pipe_done = &info->in_done;
4203 info->in_done = FALSE;
4204 info->in->info = info;
4208 if (!info->fp && info->in) {
4210 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4211 0, 0, 0, 0, 0, 0, 0, 0));
4213 while (!info->in_done) {
4215 _ckvmssts(sys$setast(0));
4216 done = info->in_done;
4217 if (!done) _ckvmssts(sys$clref(pipe_ef));
4218 _ckvmssts(sys$setast(1));
4219 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4222 if (info->in->buf) {
4223 n = info->in->bufsize * sizeof(char);
4224 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4227 _ckvmssts(lib$free_vm(&n, &info->in));
4229 _ckvmssts(lib$free_vm(&n, &info));
4235 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4236 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4238 info->out->pipe_done = &info->out_done;
4239 info->out_done = FALSE;
4240 info->out->info = info;
4243 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4245 info->err->pipe_done = &info->err_done;
4246 info->err_done = FALSE;
4247 info->err->info = info;
4251 symbol[MAX_DCL_SYMBOL] = '\0';
4253 strncpy(symbol, in, MAX_DCL_SYMBOL);
4254 d_symbol.dsc$w_length = strlen(symbol);
4255 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4257 strncpy(symbol, err, MAX_DCL_SYMBOL);
4258 d_symbol.dsc$w_length = strlen(symbol);
4259 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4261 strncpy(symbol, out, MAX_DCL_SYMBOL);
4262 d_symbol.dsc$w_length = strlen(symbol);
4263 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4265 /* Done with the names for the pipes */
4270 p = vmscmd->dsc$a_pointer;
4271 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4272 if (*p == '$') p++; /* remove leading $ */
4273 while (*p == ' ' || *p == '\t') p++;
4275 for (j = 0; j < 4; j++) {
4276 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4277 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4279 strncpy(symbol, p, MAX_DCL_SYMBOL);
4280 d_symbol.dsc$w_length = strlen(symbol);
4281 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4283 if (strlen(p) > MAX_DCL_SYMBOL) {
4284 p += MAX_DCL_SYMBOL;
4289 _ckvmssts(sys$setast(0));
4290 info->next=open_pipes; /* prepend to list */
4292 _ckvmssts(sys$setast(1));
4293 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4294 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4295 * have SYS$COMMAND if we need it.
4297 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4298 0, &info->pid, &info->completion,
4299 0, popen_completion_ast,info,0,0,0));
4301 /* if we were using a tempfile, close it now */
4303 if (tpipe) fclose(tpipe);
4305 /* once the subprocess is spawned, it has copied the symbols and
4306 we can get rid of ours */
4308 for (j = 0; j < 4; j++) {
4309 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4310 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4311 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4313 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4314 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4315 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4316 vms_execfree(vmscmd);
4318 #ifdef PERL_IMPLICIT_CONTEXT
4321 PL_forkprocess = info->pid;
4326 _ckvmssts(sys$setast(0));
4328 if (!done) _ckvmssts(sys$clref(pipe_ef));
4329 _ckvmssts(sys$setast(1));
4330 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4332 *psts = info->completion;
4333 /* Caller thinks it is open and tries to close it. */
4334 /* This causes some problems, as it changes the error status */
4335 /* my_pclose(info->fp); */
4340 } /* end of safe_popen */
4343 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4345 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4349 TAINT_PROPER("popen");
4350 PERL_FLUSHALL_FOR_CHILD;
4351 return safe_popen(aTHX_ cmd,mode,&sts);
4356 /*{{{ I32 my_pclose(PerlIO *fp)*/
4357 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4359 pInfo info, last = NULL;
4360 unsigned long int retsts;
4364 for (info = open_pipes; info != NULL; last = info, info = info->next)
4365 if (info->fp == fp) break;
4367 if (info == NULL) { /* no such pipe open */
4368 set_errno(ECHILD); /* quoth POSIX */
4369 set_vaxc_errno(SS$_NONEXPR);
4373 /* If we were writing to a subprocess, insure that someone reading from
4374 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4375 * produce an EOF record in the mailbox.
4377 * well, at least sometimes it *does*, so we have to watch out for
4378 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4382 PerlIO_flush(info->fp); /* first, flush data */
4384 fflush((FILE *)info->fp);
4387 _ckvmssts(sys$setast(0));
4388 info->closing = TRUE;
4389 done = info->done && info->in_done && info->out_done && info->err_done;
4390 /* hanging on write to Perl's input? cancel it */
4391 if (info->mode == 'r' && info->out && !info->out_done) {
4392 if (info->out->chan_out) {
4393 _ckvmssts(sys$cancel(info->out->chan_out));
4394 if (!info->out->chan_in) { /* EOF generation, need AST */
4395 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4399 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4400 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4402 _ckvmssts(sys$setast(1));
4405 PerlIO_close(info->fp);
4407 fclose((FILE *)info->fp);
4410 we have to wait until subprocess completes, but ALSO wait until all
4411 the i/o completes...otherwise we'll be freeing the "info" structure
4412 that the i/o ASTs could still be using...
4416 _ckvmssts(sys$setast(0));
4417 done = info->done && info->in_done && info->out_done && info->err_done;
4418 if (!done) _ckvmssts(sys$clref(pipe_ef));
4419 _ckvmssts(sys$setast(1));
4420 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4422 retsts = info->completion;
4424 /* remove from list of open pipes */
4425 _ckvmssts(sys$setast(0));
4426 if (last) last->next = info->next;
4427 else open_pipes = info->next;
4428 _ckvmssts(sys$setast(1));
4430 /* free buffers and structures */
4433 if (info->in->buf) {
4434 n = info->in->bufsize * sizeof(char);
4435 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4438 _ckvmssts(lib$free_vm(&n, &info->in));
4441 if (info->out->buf) {
4442 n = info->out->bufsize * sizeof(char);
4443 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4446 _ckvmssts(lib$free_vm(&n, &info->out));
4449 if (info->err->buf) {
4450 n = info->err->bufsize * sizeof(char);
4451 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4454 _ckvmssts(lib$free_vm(&n, &info->err));
4457 _ckvmssts(lib$free_vm(&n, &info));
4461 } /* end of my_pclose() */
4463 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4464 /* Roll our own prototype because we want this regardless of whether
4465 * _VMS_WAIT is defined.
4467 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4469 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4470 created with popen(); otherwise partially emulate waitpid() unless
4471 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4472 Also check processes not considered by the CRTL waitpid().
4474 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4476 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4483 if (statusp) *statusp = 0;
4485 for (info = open_pipes; info != NULL; info = info->next)
4486 if (info->pid == pid) break;
4488 if (info != NULL) { /* we know about this child */
4489 while (!info->done) {
4490 _ckvmssts(sys$setast(0));
4492 if (!done) _ckvmssts(sys$clref(pipe_ef));
4493 _ckvmssts(sys$setast(1));
4494 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4497 if (statusp) *statusp = info->completion;
4501 /* child that already terminated? */
4503 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4504 if (closed_list[j].pid == pid) {
4505 if (statusp) *statusp = closed_list[j].completion;
4510 /* fall through if this child is not one of our own pipe children */
4512 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4514 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4515 * in 7.2 did we get a version that fills in the VMS completion
4516 * status as Perl has always tried to do.
4519 sts = __vms_waitpid( pid, statusp, flags );
4521 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4524 /* If the real waitpid tells us the child does not exist, we
4525 * fall through here to implement waiting for a child that
4526 * was created by some means other than exec() (say, spawned
4527 * from DCL) or to wait for a process that is not a subprocess
4528 * of the current process.
4531 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4534 $DESCRIPTOR(intdsc,"0 00:00:01");
4535 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4536 unsigned long int pidcode = JPI$_PID, mypid;
4537 unsigned long int interval[2];
4538 unsigned int jpi_iosb[2];
4539 struct itmlst_3 jpilist[2] = {
4540 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4545 /* Sorry folks, we don't presently implement rooting around for
4546 the first child we can find, and we definitely don't want to
4547 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4553 /* Get the owner of the child so I can warn if it's not mine. If the
4554 * process doesn't exist or I don't have the privs to look at it,
4555 * I can go home early.
4557 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4558 if (sts & 1) sts = jpi_iosb[0];
4570 set_vaxc_errno(sts);
4574 if (ckWARN(WARN_EXEC)) {
4575 /* remind folks they are asking for non-standard waitpid behavior */
4576 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4577 if (ownerpid != mypid)
4578 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4579 "waitpid: process %x is not a child of process %x",
4583 /* simply check on it once a second until it's not there anymore. */
4585 _ckvmssts(sys$bintim(&intdsc,interval));
4586 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4587 _ckvmssts(sys$schdwk(0,0,interval,0));
4588 _ckvmssts(sys$hiber());
4590 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4595 } /* end of waitpid() */
4600 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4602 my_gconvert(double val, int ndig, int trail, char *buf)
4604 static char __gcvtbuf[DBL_DIG+1];
4607 loc = buf ? buf : __gcvtbuf;
4609 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4611 sprintf(loc,"%.*g",ndig,val);
4617 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4618 return gcvt(val,ndig,loc);
4621 loc[0] = '0'; loc[1] = '\0';
4628 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4629 static int rms_free_search_context(struct FAB * fab)
4633 nam = fab->fab$l_nam;
4634 nam->nam$b_nop |= NAM$M_SYNCHK;
4635 nam->nam$l_rlf = NULL;
4637 return sys$parse(fab, NULL, NULL);
4640 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4641 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4642 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4643 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4644 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4645 #define rms_nam_esll(nam) nam.nam$b_esl
4646 #define rms_nam_esl(nam) nam.nam$b_esl
4647 #define rms_nam_name(nam) nam.nam$l_name
4648 #define rms_nam_namel(nam) nam.nam$l_name
4649 #define rms_nam_type(nam) nam.nam$l_type
4650 #define rms_nam_typel(nam) nam.nam$l_type
4651 #define rms_nam_ver(nam) nam.nam$l_ver
4652 #define rms_nam_verl(nam) nam.nam$l_ver
4653 #define rms_nam_rsll(nam) nam.nam$b_rsl
4654 #define rms_nam_rsl(nam) nam.nam$b_rsl
4655 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4656 #define rms_set_fna(fab, nam, name, size) \
4657 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4658 #define rms_get_fna(fab, nam) fab.fab$l_fna
4659 #define rms_set_dna(fab, nam, name, size) \
4660 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4661 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4662 #define rms_set_esa(fab, nam, name, size) \
4663 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4664 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4665 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4666 #define rms_set_rsa(nam, name, size) \
4667 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4668 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4669 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4670 #define rms_nam_name_type_l_size(nam) \
4671 (nam.nam$b_name + nam.nam$b_type)
4673 static int rms_free_search_context(struct FAB * fab)
4677 nam = fab->fab$l_naml;
4678 nam->naml$b_nop |= NAM$M_SYNCHK;
4679 nam->naml$l_rlf = NULL;
4680 nam->naml$l_long_defname_size = 0;
4683 return sys$parse(fab, NULL, NULL);
4686 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4687 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4688 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4689 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4690 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4691 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4692 #define rms_nam_esl(nam) nam.naml$b_esl
4693 #define rms_nam_name(nam) nam.naml$l_name
4694 #define rms_nam_namel(nam) nam.naml$l_long_name
4695 #define rms_nam_type(nam) nam.naml$l_type
4696 #define rms_nam_typel(nam) nam.naml$l_long_type
4697 #define rms_nam_ver(nam) nam.naml$l_ver
4698 #define rms_nam_verl(nam) nam.naml$l_long_ver
4699 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4700 #define rms_nam_rsl(nam) nam.naml$b_rsl
4701 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4702 #define rms_set_fna(fab, nam, name, size) \
4703 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4704 nam.naml$l_long_filename_size = size; \
4705 nam.naml$l_long_filename = name;}
4706 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4707 #define rms_set_dna(fab, nam, name, size) \
4708 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4709 nam.naml$l_long_defname_size = size; \
4710 nam.naml$l_long_defname = name; }
4711 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4712 #define rms_set_esa(fab, nam, name, size) \
4713 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4714 nam.naml$l_long_expand_alloc = size; \
4715 nam.naml$l_long_expand = name; }
4716 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4717 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4718 nam.naml$l_long_expand = l_name; \
4719 nam.naml$l_long_expand_alloc = l_size; }
4720 #define rms_set_rsa(nam, name, size) \
4721 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4722 nam.naml$l_long_result = name; \
4723 nam.naml$l_long_result_alloc = size; }
4724 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4725 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4726 nam.naml$l_long_result = l_name; \
4727 nam.naml$l_long_result_alloc = l_size; }
4728 #define rms_nam_name_type_l_size(nam) \
4729 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4733 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4734 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4735 * to expand file specification. Allows for a single default file
4736 * specification and a simple mask of options. If outbuf is non-NULL,
4737 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4738 * the resultant file specification is placed. If outbuf is NULL, the
4739 * resultant file specification is placed into a static buffer.
4740 * The third argument, if non-NULL, is taken to be a default file
4741 * specification string. The fourth argument is unused at present.
4742 * rmesexpand() returns the address of the resultant string if
4743 * successful, and NULL on error.
4745 * New functionality for previously unused opts value:
4746 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4747 * PERL_RMSEXPAND_M_LONG - Want output in long formst
4748 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4750 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4754 (pTHX_ const char *filespec,
4757 const char *defspec,
4762 static char __rmsexpand_retbuf[VMS_MAXRSS];
4763 char * vmsfspec, *tmpfspec;
4764 char * esa, *cp, *out = NULL;
4768 struct FAB myfab = cc$rms_fab;
4769 rms_setup_nam(mynam);
4771 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4774 /* temp hack until UTF8 is actually implemented */
4775 if (fs_utf8 != NULL)
4778 if (!filespec || !*filespec) {
4779 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4783 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4784 else outbuf = __rmsexpand_retbuf;
4792 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4793 isunix = is_unix_filespec(filespec);
4795 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4796 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4797 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4798 PerlMem_free(vmsfspec);
4803 filespec = vmsfspec;
4805 /* Unless we are forcing to VMS format, a UNIX input means
4806 * UNIX output, and that requires long names to be used
4808 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4809 opts |= PERL_RMSEXPAND_M_LONG;
4816 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4817 rms_bind_fab_nam(myfab, mynam);
4819 if (defspec && *defspec) {
4821 t_isunix = is_unix_filespec(defspec);
4823 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4824 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4825 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4826 PerlMem_free(tmpfspec);
4827 if (vmsfspec != NULL)
4828 PerlMem_free(vmsfspec);
4835 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4838 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4839 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4840 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4841 esal = PerlMem_malloc(VMS_MAXRSS);
4842 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4844 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4846 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4847 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4850 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4851 outbufl = PerlMem_malloc(VMS_MAXRSS);
4852 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4853 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4855 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4859 #ifdef NAM$M_NO_SHORT_UPCASE
4860 if (decc_efs_case_preserve)
4861 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);