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)
524 /* Don't escape again if following character is
525 * already something we escape.
527 if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
533 /* But otherwise fall through and escape it. */
535 /* Assume that this is to be escaped */
537 outspec[1] = *inspec;
541 case ' ': /* space */
542 /* Assume that this is to be escaped */
557 /* This handles the expansion of a '^' prefix to the proper character
558 * in a UNIX file specification.
560 * The output count variable contains the number of characters added
561 * to the output string.
563 * The return value is the number of characters read from the input
566 static int copy_expand_vms_filename_escape
567 (char *outspec, const char *inspec, int *output_cnt)
574 if (*inspec == '^') {
577 /* Spaces and non-trailing dots should just be passed through,
578 * but eat the escape character.
585 case '_': /* space */
591 /* Hmm. Better leave the escape escaped. */
597 case 'U': /* Unicode - FIX-ME this is wrong. */
600 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
603 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
604 outspec[0] == c1 & 0xff;
605 outspec[1] == c2 & 0xff;
612 /* Error - do best we can to continue */
622 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
626 scnt = sscanf(inspec, "%2x", &c1);
627 outspec[0] = c1 & 0xff;
651 (const struct dsc$descriptor_s * srcstr,
652 struct filescan_itmlst_2 * valuelist,
653 unsigned long * fldflags,
654 struct dsc$descriptor_s *auxout,
655 unsigned short * retlen);
658 /* vms_split_path - Verify that the input file specification is a
659 * VMS format file specification, and provide pointers to the components of
660 * it. With EFS format filenames, this is virtually the only way to
661 * parse a VMS path specification into components.
663 * If the sum of the components do not add up to the length of the
664 * string, then the passed file specification is probably a UNIX style
667 static int vms_split_path
682 struct dsc$descriptor path_desc;
686 struct filescan_itmlst_2 item_list[9];
687 const int filespec = 0;
688 const int nodespec = 1;
689 const int devspec = 2;
690 const int rootspec = 3;
691 const int dirspec = 4;
692 const int namespec = 5;
693 const int typespec = 6;
694 const int verspec = 7;
696 /* Assume the worst for an easy exit */
711 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
712 path_desc.dsc$w_length = strlen(path);
713 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
714 path_desc.dsc$b_class = DSC$K_CLASS_S;
716 /* Get the total length, if it is shorter than the string passed
717 * then this was probably not a VMS formatted file specification
719 item_list[filespec].itmcode = FSCN$_FILESPEC;
720 item_list[filespec].length = 0;
721 item_list[filespec].component = NULL;
723 /* If the node is present, then it gets considered as part of the
724 * volume name to hopefully make things simple.
726 item_list[nodespec].itmcode = FSCN$_NODE;
727 item_list[nodespec].length = 0;
728 item_list[nodespec].component = NULL;
730 item_list[devspec].itmcode = FSCN$_DEVICE;
731 item_list[devspec].length = 0;
732 item_list[devspec].component = NULL;
734 /* root is a special case, adding it to either the directory or
735 * the device components will probalby complicate things for the
736 * callers of this routine, so leave it separate.
738 item_list[rootspec].itmcode = FSCN$_ROOT;
739 item_list[rootspec].length = 0;
740 item_list[rootspec].component = NULL;
742 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
743 item_list[dirspec].length = 0;
744 item_list[dirspec].component = NULL;
746 item_list[namespec].itmcode = FSCN$_NAME;
747 item_list[namespec].length = 0;
748 item_list[namespec].component = NULL;
750 item_list[typespec].itmcode = FSCN$_TYPE;
751 item_list[typespec].length = 0;
752 item_list[typespec].component = NULL;
754 item_list[verspec].itmcode = FSCN$_VERSION;
755 item_list[verspec].length = 0;
756 item_list[verspec].component = NULL;
758 item_list[8].itmcode = 0;
759 item_list[8].length = 0;
760 item_list[8].component = NULL;
762 status = sys$filescan
763 ((const struct dsc$descriptor_s *)&path_desc, item_list,
765 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
767 /* If we parsed it successfully these two lengths should be the same */
768 if (path_desc.dsc$w_length != item_list[filespec].length)
771 /* If we got here, then it is a VMS file specification */
774 /* set the volume name */
775 if (item_list[nodespec].length > 0) {
776 *volume = item_list[nodespec].component;
777 *vol_len = item_list[nodespec].length + item_list[devspec].length;
780 *volume = item_list[devspec].component;
781 *vol_len = item_list[devspec].length;
784 *root = item_list[rootspec].component;
785 *root_len = item_list[rootspec].length;
787 *dir = item_list[dirspec].component;
788 *dir_len = item_list[dirspec].length;
790 /* Now fun with versions and EFS file specifications
791 * The parser can not tell the difference when a "." is a version
792 * delimiter or a part of the file specification.
794 if ((decc_efs_charset) &&
795 (item_list[verspec].length > 0) &&
796 (item_list[verspec].component[0] == '.')) {
797 *name = item_list[namespec].component;
798 *name_len = item_list[namespec].length + item_list[typespec].length;
799 *ext = item_list[verspec].component;
800 *ext_len = item_list[verspec].length;
805 *name = item_list[namespec].component;
806 *name_len = item_list[namespec].length;
807 *ext = item_list[typespec].component;
808 *ext_len = item_list[typespec].length;
809 *version = item_list[verspec].component;
810 *ver_len = item_list[verspec].length;
817 * Routine to retrieve the maximum equivalence index for an input
818 * logical name. Some calls to this routine have no knowledge if
819 * the variable is a logical or not. So on error we return a max
822 /*{{{int my_maxidx(const char *lnm) */
824 my_maxidx(const char *lnm)
828 int attr = LNM$M_CASE_BLIND;
829 struct dsc$descriptor lnmdsc;
830 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
833 lnmdsc.dsc$w_length = strlen(lnm);
834 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
835 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
836 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
838 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
839 if ((status & 1) == 0)
846 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
848 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
849 struct dsc$descriptor_s **tabvec, unsigned long int flags)
852 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
853 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
854 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
856 unsigned char acmode;
857 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
858 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
859 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
860 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
862 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
863 #if defined(PERL_IMPLICIT_CONTEXT)
866 aTHX = PERL_GET_INTERP;
872 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
873 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
875 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
876 *cp2 = _toupper(*cp1);
877 if (cp1 - lnm > LNM$C_NAMLENGTH) {
878 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
882 lnmdsc.dsc$w_length = cp1 - lnm;
883 lnmdsc.dsc$a_pointer = uplnm;
884 uplnm[lnmdsc.dsc$w_length] = '\0';
885 secure = flags & PERL__TRNENV_SECURE;
886 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
887 if (!tabvec || !*tabvec) tabvec = env_tables;
889 for (curtab = 0; tabvec[curtab]; curtab++) {
890 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
891 if (!ivenv && !secure) {
896 Perl_warn(aTHX_ "Can't read CRTL environ\n");
899 retsts = SS$_NOLOGNAM;
900 for (i = 0; environ[i]; i++) {
901 if ((eq = strchr(environ[i],'=')) &&
902 lnmdsc.dsc$w_length == (eq - environ[i]) &&
903 !strncmp(environ[i],uplnm,eq - environ[i])) {
905 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
906 if (!eqvlen) continue;
911 if (retsts != SS$_NOLOGNAM) break;
914 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
915 !str$case_blind_compare(&tmpdsc,&clisym)) {
916 if (!ivsym && !secure) {
917 unsigned short int deflen = LNM$C_NAMLENGTH;
918 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
919 /* dynamic dsc to accomodate possible long value */
920 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
921 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
923 if (eqvlen > MAX_DCL_SYMBOL) {
924 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
925 eqvlen = MAX_DCL_SYMBOL;
926 /* Special hack--we might be called before the interpreter's */
927 /* fully initialized, in which case either thr or PL_curcop */
928 /* might be bogus. We have to check, since ckWARN needs them */
929 /* both to be valid if running threaded */
930 if (ckWARN(WARN_MISC)) {
931 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
934 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
936 _ckvmssts(lib$sfree1_dd(&eqvdsc));
937 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
938 if (retsts == LIB$_NOSUCHSYM) continue;
943 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
944 midx = my_maxidx(lnm);
945 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
946 lnmlst[1].bufadr = cp2;
948 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
949 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
950 if (retsts == SS$_NOLOGNAM) break;
951 /* PPFs have a prefix */
954 *((int *)uplnm) == *((int *)"SYS$") &&
956 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
957 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
958 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
959 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
960 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
961 memmove(eqv,eqv+4,eqvlen-4);
967 if ((retsts == SS$_IVLOGNAM) ||
968 (retsts == SS$_NOLOGNAM)) { continue; }
971 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
972 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
973 if (retsts == SS$_NOLOGNAM) continue;
976 eqvlen = strlen(eqv);
980 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
981 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
982 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
983 retsts == SS$_NOLOGNAM) {
984 set_errno(EINVAL); set_vaxc_errno(retsts);
986 else _ckvmssts(retsts);
988 } /* end of vmstrnenv */
991 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
992 /* Define as a function so we can access statics. */
993 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
995 return vmstrnenv(lnm,eqv,idx,fildev,
996 #ifdef SECURE_INTERNAL_GETENV
997 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1006 * Note: Uses Perl temp to store result so char * can be returned to
1007 * caller; this pointer will be invalidated at next Perl statement
1009 * We define this as a function rather than a macro in terms of my_getenv_len()
1010 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1013 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1015 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1018 static char *__my_getenv_eqv = NULL;
1019 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1020 unsigned long int idx = 0;
1021 int trnsuccess, success, secure, saverr, savvmserr;
1025 midx = my_maxidx(lnm) + 1;
1027 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1028 /* Set up a temporary buffer for the return value; Perl will
1029 * clean it up at the next statement transition */
1030 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1031 if (!tmpsv) return NULL;
1035 /* Assume no interpreter ==> single thread */
1036 if (__my_getenv_eqv != NULL) {
1037 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1040 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1042 eqv = __my_getenv_eqv;
1045 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1046 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1048 getcwd(eqv,LNM$C_NAMLENGTH);
1052 /* Get rid of "000000/ in rooted filespecs */
1055 zeros = strstr(eqv, "/000000/");
1056 if (zeros != NULL) {
1058 mlen = len - (zeros - eqv) - 7;
1059 memmove(zeros, &zeros[7], mlen);
1067 /* Impose security constraints only if tainting */
1069 /* Impose security constraints only if tainting */
1070 secure = PL_curinterp ? PL_tainting : will_taint;
1071 saverr = errno; savvmserr = vaxc$errno;
1078 #ifdef SECURE_INTERNAL_GETENV
1079 secure ? PERL__TRNENV_SECURE : 0
1085 /* For the getenv interface we combine all the equivalence names
1086 * of a search list logical into one value to acquire a maximum
1087 * value length of 255*128 (assuming %ENV is using logicals).
1089 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1091 /* If the name contains a semicolon-delimited index, parse it
1092 * off and make sure we only retrieve the equivalence name for
1094 if ((cp2 = strchr(lnm,';')) != NULL) {
1096 uplnm[cp2-lnm] = '\0';
1097 idx = strtoul(cp2+1,NULL,0);
1099 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1102 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1104 /* Discard NOLOGNAM on internal calls since we're often looking
1105 * for an optional name, and this "error" often shows up as the
1106 * (bogus) exit status for a die() call later on. */
1107 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1108 return success ? eqv : Nullch;
1111 } /* end of my_getenv() */
1115 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1117 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1121 unsigned long idx = 0;
1123 static char *__my_getenv_len_eqv = NULL;
1124 int secure, saverr, savvmserr;
1127 midx = my_maxidx(lnm) + 1;
1129 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1130 /* Set up a temporary buffer for the return value; Perl will
1131 * clean it up at the next statement transition */
1132 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1133 if (!tmpsv) return NULL;
1137 /* Assume no interpreter ==> single thread */
1138 if (__my_getenv_len_eqv != NULL) {
1139 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1142 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1144 buf = __my_getenv_len_eqv;
1147 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1148 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1151 getcwd(buf,LNM$C_NAMLENGTH);
1154 /* Get rid of "000000/ in rooted filespecs */
1156 zeros = strstr(buf, "/000000/");
1157 if (zeros != NULL) {
1159 mlen = *len - (zeros - buf) - 7;
1160 memmove(zeros, &zeros[7], mlen);
1169 /* Impose security constraints only if tainting */
1170 secure = PL_curinterp ? PL_tainting : will_taint;
1171 saverr = errno; savvmserr = vaxc$errno;
1178 #ifdef SECURE_INTERNAL_GETENV
1179 secure ? PERL__TRNENV_SECURE : 0
1185 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1187 if ((cp2 = strchr(lnm,';')) != NULL) {
1189 buf[cp2-lnm] = '\0';
1190 idx = strtoul(cp2+1,NULL,0);
1192 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1195 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1197 /* Get rid of "000000/ in rooted filespecs */
1200 zeros = strstr(buf, "/000000/");
1201 if (zeros != NULL) {
1203 mlen = *len - (zeros - buf) - 7;
1204 memmove(zeros, &zeros[7], mlen);
1210 /* Discard NOLOGNAM on internal calls since we're often looking
1211 * for an optional name, and this "error" often shows up as the
1212 * (bogus) exit status for a die() call later on. */
1213 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1214 return *len ? buf : Nullch;
1217 } /* end of my_getenv_len() */
1220 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1222 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1224 /*{{{ void prime_env_iter() */
1226 prime_env_iter(void)
1227 /* Fill the %ENV associative array with all logical names we can
1228 * find, in preparation for iterating over it.
1231 static int primed = 0;
1232 HV *seenhv = NULL, *envhv;
1234 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1235 unsigned short int chan;
1236 #ifndef CLI$M_TRUSTED
1237 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1239 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1240 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1242 bool have_sym = FALSE, have_lnm = FALSE;
1243 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1244 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1245 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1246 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1247 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1248 #if defined(PERL_IMPLICIT_CONTEXT)
1251 #if defined(USE_ITHREADS)
1252 static perl_mutex primenv_mutex;
1253 MUTEX_INIT(&primenv_mutex);
1256 #if defined(PERL_IMPLICIT_CONTEXT)
1257 /* We jump through these hoops because we can be called at */
1258 /* platform-specific initialization time, which is before anything is */
1259 /* set up--we can't even do a plain dTHX since that relies on the */
1260 /* interpreter structure to be initialized */
1262 aTHX = PERL_GET_INTERP;
1268 if (primed || !PL_envgv) return;
1269 MUTEX_LOCK(&primenv_mutex);
1270 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1271 envhv = GvHVn(PL_envgv);
1272 /* Perform a dummy fetch as an lval to insure that the hash table is
1273 * set up. Otherwise, the hv_store() will turn into a nullop. */
1274 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1276 for (i = 0; env_tables[i]; i++) {
1277 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1278 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1279 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1281 if (have_sym || have_lnm) {
1282 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1283 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1284 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1285 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1288 for (i--; i >= 0; i--) {
1289 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1292 for (j = 0; environ[j]; j++) {
1293 if (!(start = strchr(environ[j],'='))) {
1294 if (ckWARN(WARN_INTERNAL))
1295 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1299 sv = newSVpv(start,0);
1301 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1306 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1307 !str$case_blind_compare(&tmpdsc,&clisym)) {
1308 strcpy(cmd,"Show Symbol/Global *");
1309 cmddsc.dsc$w_length = 20;
1310 if (env_tables[i]->dsc$w_length == 12 &&
1311 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1312 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1313 flags = defflags | CLI$M_NOLOGNAM;
1316 strcpy(cmd,"Show Logical *");
1317 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1318 strcat(cmd," /Table=");
1319 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1320 cmddsc.dsc$w_length = strlen(cmd);
1322 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1323 flags = defflags | CLI$M_NOCLISYM;
1326 /* Create a new subprocess to execute each command, to exclude the
1327 * remote possibility that someone could subvert a mbx or file used
1328 * to write multiple commands to a single subprocess.
1331 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1332 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1333 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1334 defflags &= ~CLI$M_TRUSTED;
1335 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1337 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1338 if (seenhv) SvREFCNT_dec(seenhv);
1341 char *cp1, *cp2, *key;
1342 unsigned long int sts, iosb[2], retlen, keylen;
1345 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1346 if (sts & 1) sts = iosb[0] & 0xffff;
1347 if (sts == SS$_ENDOFFILE) {
1349 while (substs == 0) { sys$hiber(); wakect++;}
1350 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1355 retlen = iosb[0] >> 16;
1356 if (!retlen) continue; /* blank line */
1358 if (iosb[1] != subpid) {
1360 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1364 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1365 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1367 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1368 if (*cp1 == '(' || /* Logical name table name */
1369 *cp1 == '=' /* Next eqv of searchlist */) continue;
1370 if (*cp1 == '"') cp1++;
1371 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1372 key = cp1; keylen = cp2 - cp1;
1373 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1374 while (*cp2 && *cp2 != '=') cp2++;
1375 while (*cp2 && *cp2 == '=') cp2++;
1376 while (*cp2 && *cp2 == ' ') cp2++;
1377 if (*cp2 == '"') { /* String translation; may embed "" */
1378 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1379 cp2++; cp1--; /* Skip "" surrounding translation */
1381 else { /* Numeric translation */
1382 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1383 cp1--; /* stop on last non-space char */
1385 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1386 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1389 PERL_HASH(hash,key,keylen);
1391 if (cp1 == cp2 && *cp2 == '.') {
1392 /* A single dot usually means an unprintable character, such as a null
1393 * to indicate a zero-length value. Get the actual value to make sure.
1395 char lnm[LNM$C_NAMLENGTH+1];
1396 char eqv[MAX_DCL_SYMBOL+1];
1398 strncpy(lnm, key, keylen);
1399 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1400 sv = newSVpvn(eqv, strlen(eqv));
1403 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1407 hv_store(envhv,key,keylen,sv,hash);
1408 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1410 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1411 /* get the PPFs for this process, not the subprocess */
1412 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1413 char eqv[LNM$C_NAMLENGTH+1];
1415 for (i = 0; ppfs[i]; i++) {
1416 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1417 sv = newSVpv(eqv,trnlen);
1419 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1424 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1425 if (buf) Safefree(buf);
1426 if (seenhv) SvREFCNT_dec(seenhv);
1427 MUTEX_UNLOCK(&primenv_mutex);
1430 } /* end of prime_env_iter */
1434 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1435 /* Define or delete an element in the same "environment" as
1436 * vmstrnenv(). If an element is to be deleted, it's removed from
1437 * the first place it's found. If it's to be set, it's set in the
1438 * place designated by the first element of the table vector.
1439 * Like setenv() returns 0 for success, non-zero on error.
1442 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1445 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1446 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1448 unsigned long int retsts, usermode = PSL$C_USER;
1449 struct itmlst_3 *ile, *ilist;
1450 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1451 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1452 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1453 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1454 $DESCRIPTOR(local,"_LOCAL");
1457 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1458 return SS$_IVLOGNAM;
1461 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1462 *cp2 = _toupper(*cp1);
1463 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1464 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1465 return SS$_IVLOGNAM;
1468 lnmdsc.dsc$w_length = cp1 - lnm;
1469 if (!tabvec || !*tabvec) tabvec = env_tables;
1471 if (!eqv) { /* we're deleting n element */
1472 for (curtab = 0; tabvec[curtab]; curtab++) {
1473 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1475 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1476 if ((cp1 = strchr(environ[i],'=')) &&
1477 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1478 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1480 return setenv(lnm,"",1) ? vaxc$errno : 0;
1483 ivenv = 1; retsts = SS$_NOLOGNAM;
1485 if (ckWARN(WARN_INTERNAL))
1486 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1487 ivenv = 1; retsts = SS$_NOSUCHPGM;
1493 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1494 !str$case_blind_compare(&tmpdsc,&clisym)) {
1495 unsigned int symtype;
1496 if (tabvec[curtab]->dsc$w_length == 12 &&
1497 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1498 !str$case_blind_compare(&tmpdsc,&local))
1499 symtype = LIB$K_CLI_LOCAL_SYM;
1500 else symtype = LIB$K_CLI_GLOBAL_SYM;
1501 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1502 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1503 if (retsts == LIB$_NOSUCHSYM) continue;
1507 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1508 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1509 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1510 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1511 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1515 else { /* we're defining a value */
1516 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1518 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1520 if (ckWARN(WARN_INTERNAL))
1521 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1522 retsts = SS$_NOSUCHPGM;
1526 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1527 eqvdsc.dsc$w_length = strlen(eqv);
1528 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1529 !str$case_blind_compare(&tmpdsc,&clisym)) {
1530 unsigned int symtype;
1531 if (tabvec[0]->dsc$w_length == 12 &&
1532 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1533 !str$case_blind_compare(&tmpdsc,&local))
1534 symtype = LIB$K_CLI_LOCAL_SYM;
1535 else symtype = LIB$K_CLI_GLOBAL_SYM;
1536 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1539 if (!*eqv) eqvdsc.dsc$w_length = 1;
1540 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1542 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1543 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1544 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1545 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1546 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1547 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1550 Newx(ilist,nseg+1,struct itmlst_3);
1553 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1556 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1558 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1559 ile->itmcode = LNM$_STRING;
1561 if ((j+1) == nseg) {
1562 ile->buflen = strlen(c);
1563 /* in case we are truncating one that's too long */
1564 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1567 ile->buflen = LNM$C_NAMLENGTH;
1571 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1575 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1580 if (!(retsts & 1)) {
1582 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1583 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1584 set_errno(EVMSERR); break;
1585 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1586 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1587 set_errno(EINVAL); break;
1589 set_errno(EACCES); break;
1594 set_vaxc_errno(retsts);
1595 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1598 /* We reset error values on success because Perl does an hv_fetch()
1599 * before each hv_store(), and if the thing we're setting didn't
1600 * previously exist, we've got a leftover error message. (Of course,
1601 * this fails in the face of
1602 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1603 * in that the error reported in $! isn't spurious,
1604 * but it's right more often than not.)
1606 set_errno(0); set_vaxc_errno(retsts);
1610 } /* end of vmssetenv() */
1613 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1614 /* This has to be a function since there's a prototype for it in proto.h */
1616 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1619 int len = strlen(lnm);
1623 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1624 if (!strcmp(uplnm,"DEFAULT")) {
1625 if (eqv && *eqv) my_chdir(eqv);
1629 #ifndef RTL_USES_UTC
1630 if (len == 6 || len == 2) {
1633 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1635 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1636 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1640 (void) vmssetenv(lnm,eqv,NULL);
1644 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1646 * sets a user-mode logical in the process logical name table
1647 * used for redirection of sys$error
1650 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1652 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1653 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1654 unsigned long int iss, attr = LNM$M_CONFINE;
1655 unsigned char acmode = PSL$C_USER;
1656 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1658 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1659 d_name.dsc$w_length = strlen(name);
1661 lnmlst[0].buflen = strlen(eqv);
1662 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1664 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1665 if (!(iss&1)) lib$signal(iss);
1670 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1671 /* my_crypt - VMS password hashing
1672 * my_crypt() provides an interface compatible with the Unix crypt()
1673 * C library function, and uses sys$hash_password() to perform VMS
1674 * password hashing. The quadword hashed password value is returned
1675 * as a NUL-terminated 8 character string. my_crypt() does not change
1676 * the case of its string arguments; in order to match the behavior
1677 * of LOGINOUT et al., alphabetic characters in both arguments must
1678 * be upcased by the caller.
1680 * - fix me to call ACM services when available
1683 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1685 # ifndef UAI$C_PREFERRED_ALGORITHM
1686 # define UAI$C_PREFERRED_ALGORITHM 127
1688 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1689 unsigned short int salt = 0;
1690 unsigned long int sts;
1692 unsigned short int dsc$w_length;
1693 unsigned char dsc$b_type;
1694 unsigned char dsc$b_class;
1695 const char * dsc$a_pointer;
1696 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1697 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1698 struct itmlst_3 uailst[3] = {
1699 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1700 { sizeof salt, UAI$_SALT, &salt, 0},
1701 { 0, 0, NULL, NULL}};
1702 static char hash[9];
1704 usrdsc.dsc$w_length = strlen(usrname);
1705 usrdsc.dsc$a_pointer = usrname;
1706 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1708 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1712 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1717 set_vaxc_errno(sts);
1718 if (sts != RMS$_RNF) return NULL;
1721 txtdsc.dsc$w_length = strlen(textpasswd);
1722 txtdsc.dsc$a_pointer = textpasswd;
1723 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1724 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1727 return (char *) hash;
1729 } /* end of my_crypt() */
1733 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1734 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1735 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1737 /* fixup barenames that are directories for internal use.
1738 * There have been problems with the consistent handling of UNIX
1739 * style directory names when routines are presented with a name that
1740 * has no directory delimitors at all. So this routine will eventually
1743 static char * fixup_bare_dirnames(const char * name)
1745 if (decc_disable_to_vms_logname_translation) {
1752 * A little hack to get around a bug in some implemenation of remove()
1753 * that do not know how to delete a directory
1755 * Delete any file to which user has control access, regardless of whether
1756 * delete access is explicitly allowed.
1757 * Limitations: User must have write access to parent directory.
1758 * Does not block signals or ASTs; if interrupted in midstream
1759 * may leave file with an altered ACL.
1762 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1764 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1766 char *vmsname, *rspec;
1768 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1769 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1770 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1772 unsigned char myace$b_length;
1773 unsigned char myace$b_type;
1774 unsigned short int myace$w_flags;
1775 unsigned long int myace$l_access;
1776 unsigned long int myace$l_ident;
1777 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1778 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1779 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1781 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1782 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1783 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1784 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1785 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1786 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1788 /* Expand the input spec using RMS, since the CRTL remove() and
1789 * system services won't do this by themselves, so we may miss
1790 * a file "hiding" behind a logical name or search list. */
1791 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1792 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1794 if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1795 PerlMem_free(vmsname);
1799 if (decc_posix_compliant_pathnames) {
1800 /* In POSIX mode, we prefer to remove the UNIX name */
1802 remove_name = (char *)name;
1805 rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1806 if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1807 if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1808 PerlMem_free(rspec);
1809 PerlMem_free(vmsname);
1812 PerlMem_free(vmsname);
1813 remove_name = rspec;
1816 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1818 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1819 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1820 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1822 do_pathify_dirspec(name, remove_name, 0, NULL);
1823 if (!rmdir(remove_name)) {
1825 PerlMem_free(remove_name);
1826 PerlMem_free(rspec);
1827 return 0; /* Can we just get rid of it? */
1831 if (!rmdir(remove_name)) {
1832 PerlMem_free(rspec);
1833 return 0; /* Can we just get rid of it? */
1839 if (!remove(remove_name)) {
1840 PerlMem_free(rspec);
1841 return 0; /* Can we just get rid of it? */
1844 /* If not, can changing protections help? */
1845 if (vaxc$errno != RMS$_PRV) {
1846 PerlMem_free(rspec);
1850 /* No, so we get our own UIC to use as a rights identifier,
1851 * and the insert an ACE at the head of the ACL which allows us
1852 * to delete the file.
1854 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1855 fildsc.dsc$w_length = strlen(rspec);
1856 fildsc.dsc$a_pointer = rspec;
1858 newace.myace$l_ident = oldace.myace$l_ident;
1859 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1861 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1862 set_errno(ENOENT); break;
1864 set_errno(ENOTDIR); break;
1866 set_errno(ENODEV); break;
1867 case RMS$_SYN: case SS$_INVFILFOROP:
1868 set_errno(EINVAL); break;
1870 set_errno(EACCES); break;
1874 set_vaxc_errno(aclsts);
1875 PerlMem_free(rspec);
1878 /* Grab any existing ACEs with this identifier in case we fail */
1879 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1880 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1881 || fndsts == SS$_NOMOREACE ) {
1882 /* Add the new ACE . . . */
1883 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1886 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1888 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1889 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1890 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1892 do_pathify_dirspec(name, remove_name, 0, NULL);
1893 rmsts = rmdir(remove_name);
1894 PerlMem_free(remove_name);
1897 rmsts = rmdir(remove_name);
1901 rmsts = remove(remove_name);
1903 /* We blew it - dir with files in it, no write priv for
1904 * parent directory, etc. Put things back the way they were. */
1905 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1908 addlst[0].bufadr = &oldace;
1909 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1916 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1917 /* We just deleted it, so of course it's not there. Some versions of
1918 * VMS seem to return success on the unlock operation anyhow (after all
1919 * the unlock is successful), but others don't.
1921 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1922 if (aclsts & 1) aclsts = fndsts;
1923 if (!(aclsts & 1)) {
1925 set_vaxc_errno(aclsts);
1926 PerlMem_free(rspec);
1930 PerlMem_free(rspec);
1933 } /* end of kill_file() */
1937 /*{{{int do_rmdir(char *name)*/
1939 Perl_do_rmdir(pTHX_ const char *name)
1941 char dirfile[NAM$C_MAXRSS+1];
1945 if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1946 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1947 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1950 } /* end of do_rmdir */
1954 * Delete any file to which user has control access, regardless of whether
1955 * delete access is explicitly allowed.
1956 * Limitations: User must have write access to parent directory.
1957 * Does not block signals or ASTs; if interrupted in midstream
1958 * may leave file with an altered ACL.
1961 /*{{{int kill_file(char *name)*/
1963 Perl_kill_file(pTHX_ const char *name)
1965 char rspec[NAM$C_MAXRSS+1];
1967 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1968 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1969 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1971 unsigned char myace$b_length;
1972 unsigned char myace$b_type;
1973 unsigned short int myace$w_flags;
1974 unsigned long int myace$l_access;
1975 unsigned long int myace$l_ident;
1976 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1977 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1978 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1980 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1981 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1982 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1983 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1984 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1985 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1987 /* Expand the input spec using RMS, since the CRTL remove() and
1988 * system services won't do this by themselves, so we may miss
1989 * a file "hiding" behind a logical name or search list. */
1990 tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1991 if (tspec == NULL) return -1;
1992 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1993 /* If not, can changing protections help? */
1994 if (vaxc$errno != RMS$_PRV) return -1;
1996 /* No, so we get our own UIC to use as a rights identifier,
1997 * and the insert an ACE at the head of the ACL which allows us
1998 * to delete the file.
2000 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
2001 fildsc.dsc$w_length = strlen(rspec);
2002 fildsc.dsc$a_pointer = rspec;
2004 newace.myace$l_ident = oldace.myace$l_ident;
2005 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2007 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2008 set_errno(ENOENT); break;
2010 set_errno(ENOTDIR); break;
2012 set_errno(ENODEV); break;
2013 case RMS$_SYN: case SS$_INVFILFOROP:
2014 set_errno(EINVAL); break;
2016 set_errno(EACCES); break;
2020 set_vaxc_errno(aclsts);
2023 /* Grab any existing ACEs with this identifier in case we fail */
2024 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2025 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2026 || fndsts == SS$_NOMOREACE ) {
2027 /* Add the new ACE . . . */
2028 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2030 if ((rmsts = remove(name))) {
2031 /* We blew it - dir with files in it, no write priv for
2032 * parent directory, etc. Put things back the way they were. */
2033 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2036 addlst[0].bufadr = &oldace;
2037 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2044 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2045 /* We just deleted it, so of course it's not there. Some versions of
2046 * VMS seem to return success on the unlock operation anyhow (after all
2047 * the unlock is successful), but others don't.
2049 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2050 if (aclsts & 1) aclsts = fndsts;
2051 if (!(aclsts & 1)) {
2053 set_vaxc_errno(aclsts);
2059 } /* end of kill_file() */
2063 /*{{{int my_mkdir(char *,Mode_t)*/
2065 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2067 STRLEN dirlen = strlen(dir);
2069 /* zero length string sometimes gives ACCVIO */
2070 if (dirlen == 0) return -1;
2072 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2073 * null file name/type. However, it's commonplace under Unix,
2074 * so we'll allow it for a gain in portability.
2076 if (dir[dirlen-1] == '/') {
2077 char *newdir = savepvn(dir,dirlen-1);
2078 int ret = mkdir(newdir,mode);
2082 else return mkdir(dir,mode);
2083 } /* end of my_mkdir */
2086 /*{{{int my_chdir(char *)*/
2088 Perl_my_chdir(pTHX_ const char *dir)
2090 STRLEN dirlen = strlen(dir);
2092 /* zero length string sometimes gives ACCVIO */
2093 if (dirlen == 0) return -1;
2096 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2097 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2098 * so that existing scripts do not need to be changed.
2101 while ((dirlen > 0) && (*dir1 == ' ')) {
2106 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2108 * null file name/type. However, it's commonplace under Unix,
2109 * so we'll allow it for a gain in portability.
2111 * - Preview- '/' will be valid soon on VMS
2113 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2114 char *newdir = savepvn(dir1,dirlen-1);
2115 int ret = chdir(newdir);
2119 else return chdir(dir1);
2120 } /* end of my_chdir */
2124 /*{{{FILE *my_tmpfile()*/
2131 if ((fp = tmpfile())) return fp;
2133 cp = PerlMem_malloc(L_tmpnam+24);
2134 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2136 if (decc_filename_unix_only == 0)
2137 strcpy(cp,"Sys$Scratch:");
2140 tmpnam(cp+strlen(cp));
2141 strcat(cp,".Perltmp");
2142 fp = fopen(cp,"w+","fop=dlt");
2149 #ifndef HOMEGROWN_POSIX_SIGNALS
2151 * The C RTL's sigaction fails to check for invalid signal numbers so we
2152 * help it out a bit. The docs are correct, but the actual routine doesn't
2153 * do what the docs say it will.
2155 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2157 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2158 struct sigaction* oact)
2160 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2161 SETERRNO(EINVAL, SS$_INVARG);
2164 return sigaction(sig, act, oact);
2169 #ifdef KILL_BY_SIGPRC
2170 #include <errnodef.h>
2172 /* We implement our own kill() using the undocumented system service
2173 sys$sigprc for one of two reasons:
2175 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2176 target process to do a sys$exit, which usually can't be handled
2177 gracefully...certainly not by Perl and the %SIG{} mechanism.
2179 2.) If the kill() in the CRTL can't be called from a signal
2180 handler without disappearing into the ether, i.e., the signal
2181 it purportedly sends is never trapped. Still true as of VMS 7.3.
2183 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2184 in the target process rather than calling sys$exit.
2186 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2187 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2188 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2189 with condition codes C$_SIG0+nsig*8, catching the exception on the
2190 target process and resignaling with appropriate arguments.
2192 But we don't have that VMS 7.0+ exception handler, so if you
2193 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2195 Also note that SIGTERM is listed in the docs as being "unimplemented",
2196 yet always seems to be signaled with a VMS condition code of 4 (and
2197 correctly handled for that code). So we hardwire it in.
2199 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2200 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2201 than signalling with an unrecognized (and unhandled by CRTL) code.
2204 #define _MY_SIG_MAX 28
2207 Perl_sig_to_vmscondition_int(int sig)
2209 static unsigned int sig_code[_MY_SIG_MAX+1] =
2212 SS$_HANGUP, /* 1 SIGHUP */
2213 SS$_CONTROLC, /* 2 SIGINT */
2214 SS$_CONTROLY, /* 3 SIGQUIT */
2215 SS$_RADRMOD, /* 4 SIGILL */
2216 SS$_BREAK, /* 5 SIGTRAP */
2217 SS$_OPCCUS, /* 6 SIGABRT */
2218 SS$_COMPAT, /* 7 SIGEMT */
2220 SS$_FLTOVF, /* 8 SIGFPE VAX */
2222 SS$_HPARITH, /* 8 SIGFPE AXP */
2224 SS$_ABORT, /* 9 SIGKILL */
2225 SS$_ACCVIO, /* 10 SIGBUS */
2226 SS$_ACCVIO, /* 11 SIGSEGV */
2227 SS$_BADPARAM, /* 12 SIGSYS */
2228 SS$_NOMBX, /* 13 SIGPIPE */
2229 SS$_ASTFLT, /* 14 SIGALRM */
2246 #if __VMS_VER >= 60200000
2247 static int initted = 0;
2250 sig_code[16] = C$_SIGUSR1;
2251 sig_code[17] = C$_SIGUSR2;
2252 #if __CRTL_VER >= 70000000
2253 sig_code[20] = C$_SIGCHLD;
2255 #if __CRTL_VER >= 70300000
2256 sig_code[28] = C$_SIGWINCH;
2261 if (sig < _SIG_MIN) return 0;
2262 if (sig > _MY_SIG_MAX) return 0;
2263 return sig_code[sig];
2267 Perl_sig_to_vmscondition(int sig)
2270 if (vms_debug_on_exception != 0)
2271 lib$signal(SS$_DEBUG);
2273 return Perl_sig_to_vmscondition_int(sig);
2278 Perl_my_kill(int pid, int sig)
2283 int sys$sigprc(unsigned int *pidadr,
2284 struct dsc$descriptor_s *prcname,
2287 /* sig 0 means validate the PID */
2288 /*------------------------------*/
2290 const unsigned long int jpicode = JPI$_PID;
2293 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2294 if ($VMS_STATUS_SUCCESS(status))
2297 case SS$_NOSUCHNODE:
2298 case SS$_UNREACHABLE:
2312 code = Perl_sig_to_vmscondition_int(sig);
2315 SETERRNO(EINVAL, SS$_BADPARAM);
2319 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2320 * signals are to be sent to multiple processes.
2321 * pid = 0 - all processes in group except ones that the system exempts
2322 * pid = -1 - all processes except ones that the system exempts
2323 * pid = -n - all processes in group (abs(n)) except ...
2324 * For now, just report as not supported.
2328 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2332 iss = sys$sigprc((unsigned int *)&pid,0,code);
2333 if (iss&1) return 0;
2337 set_errno(EPERM); break;
2339 case SS$_NOSUCHNODE:
2340 case SS$_UNREACHABLE:
2341 set_errno(ESRCH); break;
2343 set_errno(ENOMEM); break;
2348 set_vaxc_errno(iss);
2354 /* Routine to convert a VMS status code to a UNIX status code.
2355 ** More tricky than it appears because of conflicting conventions with
2358 ** VMS status codes are a bit mask, with the least significant bit set for
2361 ** Special UNIX status of EVMSERR indicates that no translation is currently
2362 ** available, and programs should check the VMS status code.
2364 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2368 #ifndef C_FACILITY_NO
2369 #define C_FACILITY_NO 0x350000
2372 #define DCL_IVVERB 0x38090
2375 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2383 /* Assume the best or the worst */
2384 if (vms_status & STS$M_SUCCESS)
2387 unix_status = EVMSERR;
2389 msg_status = vms_status & ~STS$M_CONTROL;
2391 facility = vms_status & STS$M_FAC_NO;
2392 fac_sp = vms_status & STS$M_FAC_SP;
2393 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2395 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2401 unix_status = EFAULT;
2403 case SS$_DEVOFFLINE:
2404 unix_status = EBUSY;
2407 unix_status = ENOTCONN;
2415 case SS$_INVFILFOROP:
2419 unix_status = EINVAL;
2421 case SS$_UNSUPPORTED:
2422 unix_status = ENOTSUP;
2427 unix_status = EACCES;
2429 case SS$_DEVICEFULL:
2430 unix_status = ENOSPC;
2433 unix_status = ENODEV;
2435 case SS$_NOSUCHFILE:
2436 case SS$_NOSUCHOBJECT:
2437 unix_status = ENOENT;
2439 case SS$_ABORT: /* Fatal case */
2440 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2441 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2442 unix_status = EINTR;
2445 unix_status = E2BIG;
2448 unix_status = ENOMEM;
2451 unix_status = EPERM;
2453 case SS$_NOSUCHNODE:
2454 case SS$_UNREACHABLE:
2455 unix_status = ESRCH;
2458 unix_status = ECHILD;
2461 if ((facility == 0) && (msg_no < 8)) {
2462 /* These are not real VMS status codes so assume that they are
2463 ** already UNIX status codes
2465 unix_status = msg_no;
2471 /* Translate a POSIX exit code to a UNIX exit code */
2472 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2473 unix_status = (msg_no & 0x07F8) >> 3;
2477 /* Documented traditional behavior for handling VMS child exits */
2478 /*--------------------------------------------------------------*/
2479 if (child_flag != 0) {
2481 /* Success / Informational return 0 */
2482 /*----------------------------------*/
2483 if (msg_no & STS$K_SUCCESS)
2486 /* Warning returns 1 */
2487 /*-------------------*/
2488 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2491 /* Everything else pass through the severity bits */
2492 /*------------------------------------------------*/
2493 return (msg_no & STS$M_SEVERITY);
2496 /* Normal VMS status to ERRNO mapping attempt */
2497 /*--------------------------------------------*/
2498 switch(msg_status) {
2499 /* case RMS$_EOF: */ /* End of File */
2500 case RMS$_FNF: /* File Not Found */
2501 case RMS$_DNF: /* Dir Not Found */
2502 unix_status = ENOENT;
2504 case RMS$_RNF: /* Record Not Found */
2505 unix_status = ESRCH;
2508 unix_status = ENOTDIR;
2511 unix_status = ENODEV;
2516 unix_status = EBADF;
2519 unix_status = EEXIST;
2523 case LIB$_INVSTRDES:
2525 case LIB$_NOSUCHSYM:
2526 case LIB$_INVSYMNAM:
2528 unix_status = EINVAL;
2534 unix_status = E2BIG;
2536 case RMS$_PRV: /* No privilege */
2537 case RMS$_ACC: /* ACP file access failed */
2538 case RMS$_WLK: /* Device write locked */
2539 unix_status = EACCES;
2541 /* case RMS$_NMF: */ /* No more files */
2549 /* Try to guess at what VMS error status should go with a UNIX errno
2550 * value. This is hard to do as there could be many possible VMS
2551 * error statuses that caused the errno value to be set.
2554 int Perl_unix_status_to_vms(int unix_status)
2556 int test_unix_status;
2558 /* Trivial cases first */
2559 /*---------------------*/
2560 if (unix_status == EVMSERR)
2563 /* Is vaxc$errno sane? */
2564 /*---------------------*/
2565 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2566 if (test_unix_status == unix_status)
2569 /* If way out of range, must be VMS code already */
2570 /*-----------------------------------------------*/
2571 if (unix_status > EVMSERR)
2574 /* If out of range, punt */
2575 /*-----------------------*/
2576 if (unix_status > __ERRNO_MAX)
2580 /* Ok, now we have to do it the hard way. */
2581 /*----------------------------------------*/
2582 switch(unix_status) {
2583 case 0: return SS$_NORMAL;
2584 case EPERM: return SS$_NOPRIV;
2585 case ENOENT: return SS$_NOSUCHOBJECT;
2586 case ESRCH: return SS$_UNREACHABLE;
2587 case EINTR: return SS$_ABORT;
2590 case E2BIG: return SS$_BUFFEROVF;
2592 case EBADF: return RMS$_IFI;
2593 case ECHILD: return SS$_NONEXPR;
2595 case ENOMEM: return SS$_INSFMEM;
2596 case EACCES: return SS$_FILACCERR;
2597 case EFAULT: return SS$_ACCVIO;
2599 case EBUSY: return SS$_DEVOFFLINE;
2600 case EEXIST: return RMS$_FEX;
2602 case ENODEV: return SS$_NOSUCHDEV;
2603 case ENOTDIR: return RMS$_DIR;
2605 case EINVAL: return SS$_INVARG;
2611 case ENOSPC: return SS$_DEVICEFULL;
2612 case ESPIPE: return LIB$_INVARG;
2617 case ERANGE: return LIB$_INVARG;
2618 /* case EWOULDBLOCK */
2619 /* case EINPROGRESS */
2622 /* case EDESTADDRREQ */
2624 /* case EPROTOTYPE */
2625 /* case ENOPROTOOPT */
2626 /* case EPROTONOSUPPORT */
2627 /* case ESOCKTNOSUPPORT */
2628 /* case EOPNOTSUPP */
2629 /* case EPFNOSUPPORT */
2630 /* case EAFNOSUPPORT */
2631 /* case EADDRINUSE */
2632 /* case EADDRNOTAVAIL */
2634 /* case ENETUNREACH */
2635 /* case ENETRESET */
2636 /* case ECONNABORTED */
2637 /* case ECONNRESET */
2640 case ENOTCONN: return SS$_CLEARED;
2641 /* case ESHUTDOWN */
2642 /* case ETOOMANYREFS */
2643 /* case ETIMEDOUT */
2644 /* case ECONNREFUSED */
2646 /* case ENAMETOOLONG */
2647 /* case EHOSTDOWN */
2648 /* case EHOSTUNREACH */
2649 /* case ENOTEMPTY */
2661 /* case ECANCELED */
2665 return SS$_UNSUPPORTED;
2671 /* case EABANDONED */
2673 return SS$_ABORT; /* punt */
2676 return SS$_ABORT; /* Should not get here */
2680 /* default piping mailbox size */
2681 #define PERL_BUFSIZ 512
2685 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2687 unsigned long int mbxbufsiz;
2688 static unsigned long int syssize = 0;
2689 unsigned long int dviitm = DVI$_DEVNAM;
2690 char csize[LNM$C_NAMLENGTH+1];
2694 unsigned long syiitm = SYI$_MAXBUF;
2696 * Get the SYSGEN parameter MAXBUF
2698 * If the logical 'PERL_MBX_SIZE' is defined
2699 * use the value of the logical instead of PERL_BUFSIZ, but
2700 * keep the size between 128 and MAXBUF.
2703 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2706 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2707 mbxbufsiz = atoi(csize);
2709 mbxbufsiz = PERL_BUFSIZ;
2711 if (mbxbufsiz < 128) mbxbufsiz = 128;
2712 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2714 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2716 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2717 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2719 } /* end of create_mbx() */
2722 /*{{{ my_popen and my_pclose*/
2724 typedef struct _iosb IOSB;
2725 typedef struct _iosb* pIOSB;
2726 typedef struct _pipe Pipe;
2727 typedef struct _pipe* pPipe;
2728 typedef struct pipe_details Info;
2729 typedef struct pipe_details* pInfo;
2730 typedef struct _srqp RQE;
2731 typedef struct _srqp* pRQE;
2732 typedef struct _tochildbuf CBuf;
2733 typedef struct _tochildbuf* pCBuf;
2736 unsigned short status;
2737 unsigned short count;
2738 unsigned long dvispec;
2741 #pragma member_alignment save
2742 #pragma nomember_alignment quadword
2743 struct _srqp { /* VMS self-relative queue entry */
2744 unsigned long qptr[2];
2746 #pragma member_alignment restore
2747 static RQE RQE_ZERO = {0,0};
2749 struct _tochildbuf {
2752 unsigned short size;
2760 unsigned short chan_in;
2761 unsigned short chan_out;
2763 unsigned int bufsize;
2775 #if defined(PERL_IMPLICIT_CONTEXT)
2776 void *thx; /* Either a thread or an interpreter */
2777 /* pointer, depending on how we're built */
2785 PerlIO *fp; /* file pointer to pipe mailbox */
2786 int useFILE; /* using stdio, not perlio */
2787 int pid; /* PID of subprocess */
2788 int mode; /* == 'r' if pipe open for reading */
2789 int done; /* subprocess has completed */
2790 int waiting; /* waiting for completion/closure */
2791 int closing; /* my_pclose is closing this pipe */
2792 unsigned long completion; /* termination status of subprocess */
2793 pPipe in; /* pipe in to sub */
2794 pPipe out; /* pipe out of sub */
2795 pPipe err; /* pipe of sub's sys$error */
2796 int in_done; /* true when in pipe finished */
2799 unsigned short xchan; /* channel to debug xterm */
2800 unsigned short xchan_valid; /* channel is assigned */
2803 struct exit_control_block
2805 struct exit_control_block *flink;
2806 unsigned long int (*exit_routine)();
2807 unsigned long int arg_count;
2808 unsigned long int *status_address;
2809 unsigned long int exit_status;
2812 typedef struct _closed_pipes Xpipe;
2813 typedef struct _closed_pipes* pXpipe;
2815 struct _closed_pipes {
2816 int pid; /* PID of subprocess */
2817 unsigned long completion; /* termination status of subprocess */
2819 #define NKEEPCLOSED 50
2820 static Xpipe closed_list[NKEEPCLOSED];
2821 static int closed_index = 0;
2822 static int closed_num = 0;
2824 #define RETRY_DELAY "0 ::0.20"
2825 #define MAX_RETRY 50
2827 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2828 static unsigned long mypid;
2829 static unsigned long delaytime[2];
2831 static pInfo open_pipes = NULL;
2832 static $DESCRIPTOR(nl_desc, "NL:");
2834 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2838 static unsigned long int
2839 pipe_exit_routine(pTHX)
2842 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2843 int sts, did_stuff, need_eof, j;
2846 * Flush any pending i/o, but since we are in process run-down, be
2847 * careful about referencing PerlIO structures that may already have
2848 * been deallocated. We may not even have an interpreter anymore.
2854 #if defined(USE_ITHREADS)
2857 && PL_perlio_fd_refcnt)
2858 PerlIO_flush(info->fp);
2860 fflush((FILE *)info->fp);
2866 next we try sending an EOF...ignore if doesn't work, make sure we
2874 _ckvmssts_noperl(sys$setast(0));
2875 if (info->in && !info->in->shut_on_empty) {
2876 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2881 _ckvmssts_noperl(sys$setast(1));
2885 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2887 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2892 _ckvmssts_noperl(sys$setast(0));
2893 if (info->waiting && info->done)
2895 nwait += info->waiting;
2896 _ckvmssts_noperl(sys$setast(1));
2906 _ckvmssts_noperl(sys$setast(0));
2907 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2908 sts = sys$forcex(&info->pid,0,&abort);
2909 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2912 _ckvmssts_noperl(sys$setast(1));
2916 /* again, wait for effect */
2918 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2923 _ckvmssts_noperl(sys$setast(0));
2924 if (info->waiting && info->done)
2926 nwait += info->waiting;
2927 _ckvmssts_noperl(sys$setast(1));
2936 _ckvmssts_noperl(sys$setast(0));
2937 if (!info->done) { /* We tried to be nice . . . */
2938 sts = sys$delprc(&info->pid,0);
2939 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2940 info->done = 1; /* sys$delprc is as done as we're going to get. */
2942 _ckvmssts_noperl(sys$setast(1));
2947 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2948 else if (!(sts & 1)) retsts = sts;
2953 static struct exit_control_block pipe_exitblock =
2954 {(struct exit_control_block *) 0,
2955 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2957 static void pipe_mbxtofd_ast(pPipe p);
2958 static void pipe_tochild1_ast(pPipe p);
2959 static void pipe_tochild2_ast(pPipe p);
2962 popen_completion_ast(pInfo info)
2964 pInfo i = open_pipes;
2969 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2970 closed_list[closed_index].pid = info->pid;
2971 closed_list[closed_index].completion = info->completion;
2973 if (closed_index == NKEEPCLOSED)
2978 if (i == info) break;
2981 if (!i) return; /* unlinked, probably freed too */
2986 Writing to subprocess ...
2987 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2989 chan_out may be waiting for "done" flag, or hung waiting
2990 for i/o completion to child...cancel the i/o. This will
2991 put it into "snarf mode" (done but no EOF yet) that discards
2994 Output from subprocess (stdout, stderr) needs to be flushed and
2995 shut down. We try sending an EOF, but if the mbx is full the pipe
2996 routine should still catch the "shut_on_empty" flag, telling it to
2997 use immediate-style reads so that "mbx empty" -> EOF.
3001 if (info->in && !info->in_done) { /* only for mode=w */
3002 if (info->in->shut_on_empty && info->in->need_wake) {
3003 info->in->need_wake = FALSE;
3004 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3006 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3010 if (info->out && !info->out_done) { /* were we also piping output? */
3011 info->out->shut_on_empty = TRUE;
3012 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3013 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3014 _ckvmssts_noperl(iss);
3017 if (info->err && !info->err_done) { /* we were piping stderr */
3018 info->err->shut_on_empty = TRUE;
3019 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3020 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3021 _ckvmssts_noperl(iss);
3023 _ckvmssts_noperl(sys$setef(pipe_ef));
3027 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3028 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3031 we actually differ from vmstrnenv since we use this to
3032 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3033 are pointing to the same thing
3036 static unsigned short
3037 popen_translate(pTHX_ char *logical, char *result)
3040 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3041 $DESCRIPTOR(d_log,"");
3043 unsigned short length;
3044 unsigned short code;
3046 unsigned short *retlenaddr;
3048 unsigned short l, ifi;
3050 d_log.dsc$a_pointer = logical;
3051 d_log.dsc$w_length = strlen(logical);
3053 itmlst[0].code = LNM$_STRING;
3054 itmlst[0].length = 255;
3055 itmlst[0].buffer_addr = result;
3056 itmlst[0].retlenaddr = &l;
3059 itmlst[1].length = 0;
3060 itmlst[1].buffer_addr = 0;
3061 itmlst[1].retlenaddr = 0;
3063 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3064 if (iss == SS$_NOLOGNAM) {
3068 if (!(iss&1)) lib$signal(iss);
3071 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3072 strip it off and return the ifi, if any
3075 if (result[0] == 0x1b && result[1] == 0x00) {
3076 memmove(&ifi,result+2,2);
3077 strcpy(result,result+4);
3079 return ifi; /* this is the RMS internal file id */
3082 static void pipe_infromchild_ast(pPipe p);
3085 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3086 inside an AST routine without worrying about reentrancy and which Perl
3087 memory allocator is being used.
3089 We read data and queue up the buffers, then spit them out one at a
3090 time to the output mailbox when the output mailbox is ready for one.
3093 #define INITIAL_TOCHILDQUEUE 2
3096 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3100 char mbx1[64], mbx2[64];
3101 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3102 DSC$K_CLASS_S, mbx1},
3103 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3104 DSC$K_CLASS_S, mbx2};
3105 unsigned int dviitm = DVI$_DEVBUFSIZ;
3109 _ckvmssts(lib$get_vm(&n, &p));
3111 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3112 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3113 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3116 p->shut_on_empty = FALSE;
3117 p->need_wake = FALSE;
3120 p->iosb.status = SS$_NORMAL;
3121 p->iosb2.status = SS$_NORMAL;
3127 #ifdef PERL_IMPLICIT_CONTEXT
3131 n = sizeof(CBuf) + p->bufsize;
3133 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3134 _ckvmssts(lib$get_vm(&n, &b));
3135 b->buf = (char *) b + sizeof(CBuf);
3136 _ckvmssts(lib$insqhi(b, &p->free));
3139 pipe_tochild2_ast(p);
3140 pipe_tochild1_ast(p);
3146 /* reads the MBX Perl is writing, and queues */
3149 pipe_tochild1_ast(pPipe p)
3152 int iss = p->iosb.status;
3153 int eof = (iss == SS$_ENDOFFILE);
3155 #ifdef PERL_IMPLICIT_CONTEXT
3161 p->shut_on_empty = TRUE;
3163 _ckvmssts(sys$dassgn(p->chan_in));
3169 b->size = p->iosb.count;
3170 _ckvmssts(sts = lib$insqhi(b, &p->wait));
3172 p->need_wake = FALSE;
3173 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3176 p->retry = 1; /* initial call */
3179 if (eof) { /* flush the free queue, return when done */
3180 int n = sizeof(CBuf) + p->bufsize;
3182 iss = lib$remqti(&p->free, &b);
3183 if (iss == LIB$_QUEWASEMP) return;
3185 _ckvmssts(lib$free_vm(&n, &b));
3189 iss = lib$remqti(&p->free, &b);
3190 if (iss == LIB$_QUEWASEMP) {
3191 int n = sizeof(CBuf) + p->bufsize;
3192 _ckvmssts(lib$get_vm(&n, &b));
3193 b->buf = (char *) b + sizeof(CBuf);
3199 iss = sys$qio(0,p->chan_in,
3200 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3202 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3203 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3208 /* writes queued buffers to output, waits for each to complete before
3212 pipe_tochild2_ast(pPipe p)
3215 int iss = p->iosb2.status;
3216 int n = sizeof(CBuf) + p->bufsize;
3217 int done = (p->info && p->info->done) ||
3218 iss == SS$_CANCEL || iss == SS$_ABORT;
3219 #if defined(PERL_IMPLICIT_CONTEXT)
3224 if (p->type) { /* type=1 has old buffer, dispose */
3225 if (p->shut_on_empty) {
3226 _ckvmssts(lib$free_vm(&n, &b));
3228 _ckvmssts(lib$insqhi(b, &p->free));
3233 iss = lib$remqti(&p->wait, &b);
3234 if (iss == LIB$_QUEWASEMP) {
3235 if (p->shut_on_empty) {
3237 _ckvmssts(sys$dassgn(p->chan_out));
3238 *p->pipe_done = TRUE;
3239 _ckvmssts(sys$setef(pipe_ef));
3241 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3242 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3246 p->need_wake = TRUE;
3256 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3257 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3259 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3260 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3269 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3272 char mbx1[64], mbx2[64];
3273 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3274 DSC$K_CLASS_S, mbx1},
3275 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3276 DSC$K_CLASS_S, mbx2};
3277 unsigned int dviitm = DVI$_DEVBUFSIZ;
3279 int n = sizeof(Pipe);
3280 _ckvmssts(lib$get_vm(&n, &p));
3281 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3282 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3284 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3285 n = p->bufsize * sizeof(char);
3286 _ckvmssts(lib$get_vm(&n, &p->buf));
3287 p->shut_on_empty = FALSE;
3290 p->iosb.status = SS$_NORMAL;
3291 #if defined(PERL_IMPLICIT_CONTEXT)
3294 pipe_infromchild_ast(p);
3302 pipe_infromchild_ast(pPipe p)
3304 int iss = p->iosb.status;
3305 int eof = (iss == SS$_ENDOFFILE);
3306 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3307 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3308 #if defined(PERL_IMPLICIT_CONTEXT)
3312 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3313 _ckvmssts(sys$dassgn(p->chan_out));
3318 input shutdown if EOF from self (done or shut_on_empty)
3319 output shutdown if closing flag set (my_pclose)
3320 send data/eof from child or eof from self
3321 otherwise, re-read (snarf of data from child)
3326 if (myeof && p->chan_in) { /* input shutdown */
3327 _ckvmssts(sys$dassgn(p->chan_in));
3332 if (myeof || kideof) { /* pass EOF to parent */
3333 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3334 pipe_infromchild_ast, p,
3337 } else if (eof) { /* eat EOF --- fall through to read*/
3339 } else { /* transmit data */
3340 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3341 pipe_infromchild_ast,p,
3342 p->buf, p->iosb.count, 0, 0, 0, 0));
3348 /* everything shut? flag as done */
3350 if (!p->chan_in && !p->chan_out) {
3351 *p->pipe_done = TRUE;
3352 _ckvmssts(sys$setef(pipe_ef));
3356 /* write completed (or read, if snarfing from child)
3357 if still have input active,
3358 queue read...immediate mode if shut_on_empty so we get EOF if empty
3360 check if Perl reading, generate EOFs as needed
3366 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3367 pipe_infromchild_ast,p,
3368 p->buf, p->bufsize, 0, 0, 0, 0);
3369 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3371 } else { /* send EOFs for extra reads */
3372 p->iosb.status = SS$_ENDOFFILE;
3373 p->iosb.dvispec = 0;
3374 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3376 pipe_infromchild_ast, p, 0, 0, 0, 0));
3382 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3386 unsigned long dviitm = DVI$_DEVBUFSIZ;
3388 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3389 DSC$K_CLASS_S, mbx};
3390 int n = sizeof(Pipe);
3392 /* things like terminals and mbx's don't need this filter */
3393 if (fd && fstat(fd,&s) == 0) {
3394 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3396 unsigned short dev_len;
3397 struct dsc$descriptor_s d_dev;
3399 struct item_list_3 items[3];
3401 unsigned short dvi_iosb[4];
3403 cptr = getname(fd, out, 1);
3404 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3405 d_dev.dsc$a_pointer = out;
3406 d_dev.dsc$w_length = strlen(out);
3407 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3408 d_dev.dsc$b_class = DSC$K_CLASS_S;
3411 items[0].code = DVI$_DEVCHAR;
3412 items[0].bufadr = &devchar;
3413 items[0].retadr = NULL;
3415 items[1].code = DVI$_FULLDEVNAM;
3416 items[1].bufadr = device;
3417 items[1].retadr = &dev_len;
3421 status = sys$getdviw
3422 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3424 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3425 device[dev_len] = 0;
3427 if (!(devchar & DEV$M_DIR)) {
3428 strcpy(out, device);
3434 _ckvmssts(lib$get_vm(&n, &p));
3435 p->fd_out = dup(fd);
3436 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3437 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3438 n = (p->bufsize+1) * sizeof(char);
3439 _ckvmssts(lib$get_vm(&n, &p->buf));
3440 p->shut_on_empty = FALSE;
3445 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3446 pipe_mbxtofd_ast, p,
3447 p->buf, p->bufsize, 0, 0, 0, 0));
3453 pipe_mbxtofd_ast(pPipe p)
3455 int iss = p->iosb.status;
3456 int done = p->info->done;
3458 int eof = (iss == SS$_ENDOFFILE);
3459 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3460 int err = !(iss&1) && !eof;
3461 #if defined(PERL_IMPLICIT_CONTEXT)
3465 if (done && myeof) { /* end piping */
3467 sys$dassgn(p->chan_in);
3468 *p->pipe_done = TRUE;
3469 _ckvmssts(sys$setef(pipe_ef));
3473 if (!err && !eof) { /* good data to send to file */
3474 p->buf[p->iosb.count] = '\n';
3475 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3478 if (p->retry < MAX_RETRY) {
3479 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3489 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3490 pipe_mbxtofd_ast, p,
3491 p->buf, p->bufsize, 0, 0, 0, 0);
3492 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3497 typedef struct _pipeloc PLOC;
3498 typedef struct _pipeloc* pPLOC;
3502 char dir[NAM$C_MAXRSS+1];
3504 static pPLOC head_PLOC = 0;
3507 free_pipelocs(pTHX_ void *head)
3510 pPLOC *pHead = (pPLOC *)head;
3522 store_pipelocs(pTHX)
3531 char temp[NAM$C_MAXRSS+1];
3535 free_pipelocs(aTHX_ &head_PLOC);
3537 /* the . directory from @INC comes last */
3539 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3540 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3541 p->next = head_PLOC;
3543 strcpy(p->dir,"./");
3545 /* get the directory from $^X */
3547 unixdir = PerlMem_malloc(VMS_MAXRSS);
3548 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3550 #ifdef PERL_IMPLICIT_CONTEXT
3551 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3553 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3555 strcpy(temp, PL_origargv[0]);
3556 x = strrchr(temp,']');
3558 x = strrchr(temp,'>');
3560 /* It could be a UNIX path */
3561 x = strrchr(temp,'/');
3567 /* Got a bare name, so use default directory */
3572 if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3573 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3574 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3575 p->next = head_PLOC;
3577 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3578 p->dir[NAM$C_MAXRSS] = '\0';
3582 /* reverse order of @INC entries, skip "." since entered above */
3584 #ifdef PERL_IMPLICIT_CONTEXT
3587 if (PL_incgv) av = GvAVn(PL_incgv);
3589 for (i = 0; av && i <= AvFILL(av); i++) {
3590 dirsv = *av_fetch(av,i,TRUE);
3592 if (SvROK(dirsv)) continue;
3593 dir = SvPVx(dirsv,n_a);
3594 if (strcmp(dir,".") == 0) continue;
3595 if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3598 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3599 p->next = head_PLOC;
3601 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3602 p->dir[NAM$C_MAXRSS] = '\0';
3605 /* most likely spot (ARCHLIB) put first in the list */
3608 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3609 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3610 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3611 p->next = head_PLOC;
3613 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3614 p->dir[NAM$C_MAXRSS] = '\0';
3617 PerlMem_free(unixdir);
3621 Perl_cando_by_name_int
3622 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3623 #if !defined(PERL_IMPLICIT_CONTEXT)
3624 #define cando_by_name_int Perl_cando_by_name_int
3626 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3632 static int vmspipe_file_status = 0;
3633 static char vmspipe_file[NAM$C_MAXRSS+1];
3635 /* already found? Check and use ... need read+execute permission */
3637 if (vmspipe_file_status == 1) {
3638 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3639 && cando_by_name_int
3640 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3641 return vmspipe_file;
3643 vmspipe_file_status = 0;
3646 /* scan through stored @INC, $^X */
3648 if (vmspipe_file_status == 0) {
3649 char file[NAM$C_MAXRSS+1];
3650 pPLOC p = head_PLOC;
3655 strcpy(file, p->dir);
3656 dirlen = strlen(file);
3657 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3658 file[NAM$C_MAXRSS] = '\0';
3661 exp_res = do_rmsexpand
3662 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3663 if (!exp_res) continue;
3665 if (cando_by_name_int
3666 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3667 && cando_by_name_int
3668 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3669 vmspipe_file_status = 1;
3670 return vmspipe_file;
3673 vmspipe_file_status = -1; /* failed, use tempfiles */
3680 vmspipe_tempfile(pTHX)
3682 char file[NAM$C_MAXRSS+1];
3684 static int index = 0;
3688 /* create a tempfile */
3690 /* we can't go from W, shr=get to R, shr=get without
3691 an intermediate vulnerable state, so don't bother trying...
3693 and lib$spawn doesn't shr=put, so have to close the write
3695 So... match up the creation date/time and the FID to
3696 make sure we're dealing with the same file
3701 if (!decc_filename_unix_only) {
3702 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3703 fp = fopen(file,"w");
3705 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3706 fp = fopen(file,"w");
3708 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3709 fp = fopen(file,"w");
3714 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3715 fp = fopen(file,"w");
3717 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3718 fp = fopen(file,"w");
3720 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3721 fp = fopen(file,"w");
3725 if (!fp) return 0; /* we're hosed */
3727 fprintf(fp,"$! 'f$verify(0)'\n");
3728 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3729 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3730 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3731 fprintf(fp,"$ perl_on = \"set noon\"\n");
3732 fprintf(fp,"$ perl_exit = \"exit\"\n");
3733 fprintf(fp,"$ perl_del = \"delete\"\n");
3734 fprintf(fp,"$ pif = \"if\"\n");
3735 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3736 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3737 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3738 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3739 fprintf(fp,"$! --- build command line to get max possible length\n");
3740 fprintf(fp,"$c=perl_popen_cmd0\n");
3741 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3742 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3743 fprintf(fp,"$x=perl_popen_cmd3\n");
3744 fprintf(fp,"$c=c+x\n");
3745 fprintf(fp,"$ perl_on\n");
3746 fprintf(fp,"$ 'c'\n");
3747 fprintf(fp,"$ perl_status = $STATUS\n");
3748 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3749 fprintf(fp,"$ perl_exit 'perl_status'\n");
3752 fgetname(fp, file, 1);
3753 fstat(fileno(fp), (struct stat *)&s0);
3756 if (decc_filename_unix_only)
3757 do_tounixspec(file, file, 0, NULL);
3758 fp = fopen(file,"r","shr=get");
3760 fstat(fileno(fp), (struct stat *)&s1);
3762 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3763 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3772 #ifdef USE_VMS_DECTERM
3774 static int vms_is_syscommand_xterm(void)
3776 const static struct dsc$descriptor_s syscommand_dsc =
3777 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3779 const static struct dsc$descriptor_s decwdisplay_dsc =
3780 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3782 struct item_list_3 items[2];
3783 unsigned short dvi_iosb[4];
3784 unsigned long devchar;
3785 unsigned long devclass;
3788 /* Very simple check to guess if sys$command is a decterm? */
3789 /* First see if the DECW$DISPLAY: device exists */
3791 items[0].code = DVI$_DEVCHAR;
3792 items[0].bufadr = &devchar;
3793 items[0].retadr = NULL;
3797 status = sys$getdviw
3798 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3800 if ($VMS_STATUS_SUCCESS(status)) {
3801 status = dvi_iosb[0];
3804 if (!$VMS_STATUS_SUCCESS(status)) {
3805 SETERRNO(EVMSERR, status);
3809 /* If it does, then for now assume that we are on a workstation */
3810 /* Now verify that SYS$COMMAND is a terminal */
3811 /* for creating the debugger DECTerm */
3814 items[0].code = DVI$_DEVCLASS;
3815 items[0].bufadr = &devclass;
3816 items[0].retadr = NULL;
3820 status = sys$getdviw
3821 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3823 if ($VMS_STATUS_SUCCESS(status)) {
3824 status = dvi_iosb[0];
3827 if (!$VMS_STATUS_SUCCESS(status)) {
3828 SETERRNO(EVMSERR, status);
3832 if (devclass == DC$_TERM) {
3839 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3840 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3845 char device_name[65];
3846 unsigned short device_name_len;
3847 struct dsc$descriptor_s customization_dsc;
3848 struct dsc$descriptor_s device_name_dsc;
3851 char customization[200];
3855 unsigned short p_chan;
3857 unsigned short iosb[4];
3858 struct item_list_3 items[2];
3859 const char * cust_str =
3860 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3861 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3862 DSC$K_CLASS_S, mbx1};
3864 ret_char = strstr(cmd," xterm ");
3865 if (ret_char == NULL)
3867 cptr = ret_char + 7;
3868 ret_char = strstr(cmd,"tty");
3869 if (ret_char == NULL)
3871 ret_char = strstr(cmd,"sleep");
3872 if (ret_char == NULL)
3875 /* Are we on a workstation? */
3876 /* to do: capture the rows / columns and pass their properties */
3877 ret_stat = vms_is_syscommand_xterm();
3881 /* Make the title: */
3882 ret_char = strstr(cptr,"-title");
3883 if (ret_char != NULL) {
3884 while ((*cptr != 0) && (*cptr != '\"')) {
3890 while ((*cptr != 0) && (*cptr != '\"')) {
3903 strcpy(title,"Perl Debug DECTerm");
3905 sprintf(customization, cust_str, title);
3907 customization_dsc.dsc$a_pointer = customization;
3908 customization_dsc.dsc$w_length = strlen(customization);
3909 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3910 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3912 device_name_dsc.dsc$a_pointer = device_name;
3913 device_name_dsc.dsc$w_length = sizeof device_name -1;
3914 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3915 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3917 device_name_len = 0;
3919 /* Try to create the window */
3920 status = decw$term_port
3929 if (!$VMS_STATUS_SUCCESS(status)) {
3930 SETERRNO(EVMSERR, status);
3934 device_name[device_name_len] = '\0';
3936 /* Need to set this up to look like a pipe for cleanup */
3938 status = lib$get_vm(&n, &info);
3939 if (!$VMS_STATUS_SUCCESS(status)) {
3940 SETERRNO(ENOMEM, status);
3946 info->completion = 0;
3947 info->closing = FALSE;
3954 info->in_done = TRUE;
3955 info->out_done = TRUE;
3956 info->err_done = TRUE;
3958 /* Assign a channel on this so that it will persist, and not login */
3959 /* We stash this channel in the info structure for reference. */
3960 /* The created xterm self destructs when the last channel is removed */
3961 /* and it appears that perl5db.pl (perl debugger) does this routinely */
3962 /* So leave this assigned. */
3963 device_name_dsc.dsc$w_length = device_name_len;
3964 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
3965 if (!$VMS_STATUS_SUCCESS(status)) {
3966 SETERRNO(EVMSERR, status);
3969 info->xchan_valid = 1;
3971 /* Now create a mailbox to be read by the application */
3973 create_mbx(aTHX_ &p_chan, &d_mbx1);
3975 /* write the name of the created terminal to the mailbox */
3976 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
3977 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
3979 if (!$VMS_STATUS_SUCCESS(status)) {
3980 SETERRNO(EVMSERR, status);
3984 info->fp = PerlIO_open(mbx1, mode);
3986 /* Done with this channel */
3989 /* If any errors, then clean up */
3992 _ckvmssts(lib$free_vm(&n, &info));
4002 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4004 static int handler_set_up = FALSE;
4005 unsigned long int sts, flags = CLI$M_NOWAIT;
4006 /* The use of a GLOBAL table (as was done previously) rendered
4007 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4008 * environment. Hence we've switched to LOCAL symbol table.
4010 unsigned int table = LIB$K_CLI_LOCAL_SYM;
4012 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4013 char *in, *out, *err, mbx[512];
4015 char tfilebuf[NAM$C_MAXRSS+1];
4017 char cmd_sym_name[20];
4018 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4019 DSC$K_CLASS_S, symbol};
4020 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4022 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4023 DSC$K_CLASS_S, cmd_sym_name};
4024 struct dsc$descriptor_s *vmscmd;
4025 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4026 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4027 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4029 #ifdef USE_VMS_DECTERM
4030 /* Check here for Xterm create request. This means looking for
4031 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4032 * is possible to create an xterm.
4034 if (*in_mode == 'r') {
4037 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4038 if (xterm_fd != Nullfp)
4043 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4045 /* once-per-program initialization...
4046 note that the SETAST calls and the dual test of pipe_ef
4047 makes sure that only the FIRST thread through here does
4048 the initialization...all other threads wait until it's
4051 Yeah, uglier than a pthread call, it's got all the stuff inline
4052 rather than in a separate routine.
4056 _ckvmssts(sys$setast(0));
4058 unsigned long int pidcode = JPI$_PID;
4059 $DESCRIPTOR(d_delay, RETRY_DELAY);
4060 _ckvmssts(lib$get_ef(&pipe_ef));
4061 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4062 _ckvmssts(sys$bintim(&d_delay, delaytime));
4064 if (!handler_set_up) {
4065 _ckvmssts(sys$dclexh(&pipe_exitblock));
4066 handler_set_up = TRUE;
4068 _ckvmssts(sys$setast(1));
4071 /* see if we can find a VMSPIPE.COM */
4074 vmspipe = find_vmspipe(aTHX);
4076 strcpy(tfilebuf+1,vmspipe);
4077 } else { /* uh, oh...we're in tempfile hell */
4078 tpipe = vmspipe_tempfile(aTHX);
4079 if (!tpipe) { /* a fish popular in Boston */
4080 if (ckWARN(WARN_PIPE)) {
4081 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4085 fgetname(tpipe,tfilebuf+1,1);
4087 vmspipedsc.dsc$a_pointer = tfilebuf;
4088 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4090 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4093 case RMS$_FNF: case RMS$_DNF:
4094 set_errno(ENOENT); break;
4096 set_errno(ENOTDIR); break;
4098 set_errno(ENODEV); break;
4100 set_errno(EACCES); break;
4102 set_errno(EINVAL); break;
4103 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4104 set_errno(E2BIG); break;
4105 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4106 _ckvmssts(sts); /* fall through */
4107 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4110 set_vaxc_errno(sts);
4111 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4112 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4118 _ckvmssts(lib$get_vm(&n, &info));
4120 strcpy(mode,in_mode);
4123 info->completion = 0;
4124 info->closing = FALSE;
4131 info->in_done = TRUE;
4132 info->out_done = TRUE;
4133 info->err_done = TRUE;
4135 info->xchan_valid = 0;
4137 in = PerlMem_malloc(VMS_MAXRSS);
4138 if (in == NULL) _ckvmssts(SS$_INSFMEM);
4139 out = PerlMem_malloc(VMS_MAXRSS);
4140 if (out == NULL) _ckvmssts(SS$_INSFMEM);
4141 err = PerlMem_malloc(VMS_MAXRSS);
4142 if (err == NULL) _ckvmssts(SS$_INSFMEM);
4144 in[0] = out[0] = err[0] = '\0';
4146 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4150 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4155 if (*mode == 'r') { /* piping from subroutine */
4157 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4159 info->out->pipe_done = &info->out_done;
4160 info->out_done = FALSE;
4161 info->out->info = info;
4163 if (!info->useFILE) {
4164 info->fp = PerlIO_open(mbx, mode);
4166 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4167 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4170 if (!info->fp && info->out) {
4171 sys$cancel(info->out->chan_out);
4173 while (!info->out_done) {
4175 _ckvmssts(sys$setast(0));
4176 done = info->out_done;
4177 if (!done) _ckvmssts(sys$clref(pipe_ef));
4178 _ckvmssts(sys$setast(1));
4179 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4182 if (info->out->buf) {
4183 n = info->out->bufsize * sizeof(char);
4184 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4187 _ckvmssts(lib$free_vm(&n, &info->out));
4189 _ckvmssts(lib$free_vm(&n, &info));
4194 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4196 info->err->pipe_done = &info->err_done;
4197 info->err_done = FALSE;
4198 info->err->info = info;
4201 } else if (*mode == 'w') { /* piping to subroutine */
4203 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4205 info->out->pipe_done = &info->out_done;
4206 info->out_done = FALSE;
4207 info->out->info = info;
4210 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4212 info->err->pipe_done = &info->err_done;
4213 info->err_done = FALSE;
4214 info->err->info = info;
4217 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4218 if (!info->useFILE) {
4219 info->fp = PerlIO_open(mbx, mode);
4221 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4222 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4226 info->in->pipe_done = &info->in_done;
4227 info->in_done = FALSE;
4228 info->in->info = info;
4232 if (!info->fp && info->in) {
4234 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4235 0, 0, 0, 0, 0, 0, 0, 0));
4237 while (!info->in_done) {
4239 _ckvmssts(sys$setast(0));
4240 done = info->in_done;
4241 if (!done) _ckvmssts(sys$clref(pipe_ef));
4242 _ckvmssts(sys$setast(1));
4243 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4246 if (info->in->buf) {
4247 n = info->in->bufsize * sizeof(char);
4248 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4251 _ckvmssts(lib$free_vm(&n, &info->in));
4253 _ckvmssts(lib$free_vm(&n, &info));
4259 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4260 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4262 info->out->pipe_done = &info->out_done;
4263 info->out_done = FALSE;
4264 info->out->info = info;
4267 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4269 info->err->pipe_done = &info->err_done;
4270 info->err_done = FALSE;
4271 info->err->info = info;
4275 symbol[MAX_DCL_SYMBOL] = '\0';
4277 strncpy(symbol, in, MAX_DCL_SYMBOL);
4278 d_symbol.dsc$w_length = strlen(symbol);
4279 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4281 strncpy(symbol, err, MAX_DCL_SYMBOL);
4282 d_symbol.dsc$w_length = strlen(symbol);
4283 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4285 strncpy(symbol, out, MAX_DCL_SYMBOL);
4286 d_symbol.dsc$w_length = strlen(symbol);
4287 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4289 /* Done with the names for the pipes */
4294 p = vmscmd->dsc$a_pointer;
4295 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4296 if (*p == '$') p++; /* remove leading $ */
4297 while (*p == ' ' || *p == '\t') p++;
4299 for (j = 0; j < 4; j++) {
4300 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4301 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4303 strncpy(symbol, p, MAX_DCL_SYMBOL);
4304 d_symbol.dsc$w_length = strlen(symbol);
4305 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4307 if (strlen(p) > MAX_DCL_SYMBOL) {
4308 p += MAX_DCL_SYMBOL;
4313 _ckvmssts(sys$setast(0));
4314 info->next=open_pipes; /* prepend to list */
4316 _ckvmssts(sys$setast(1));
4317 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4318 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4319 * have SYS$COMMAND if we need it.
4321 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4322 0, &info->pid, &info->completion,
4323 0, popen_completion_ast,info,0,0,0));
4325 /* if we were using a tempfile, close it now */
4327 if (tpipe) fclose(tpipe);
4329 /* once the subprocess is spawned, it has copied the symbols and
4330 we can get rid of ours */
4332 for (j = 0; j < 4; j++) {
4333 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4334 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4335 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4337 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4338 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4339 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4340 vms_execfree(vmscmd);
4342 #ifdef PERL_IMPLICIT_CONTEXT
4345 PL_forkprocess = info->pid;
4350 _ckvmssts(sys$setast(0));
4352 if (!done) _ckvmssts(sys$clref(pipe_ef));
4353 _ckvmssts(sys$setast(1));
4354 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4356 *psts = info->completion;
4357 /* Caller thinks it is open and tries to close it. */
4358 /* This causes some problems, as it changes the error status */
4359 /* my_pclose(info->fp); */
4364 } /* end of safe_popen */
4367 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4369 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4373 TAINT_PROPER("popen");
4374 PERL_FLUSHALL_FOR_CHILD;
4375 return safe_popen(aTHX_ cmd,mode,&sts);
4380 /*{{{ I32 my_pclose(PerlIO *fp)*/
4381 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4383 pInfo info, last = NULL;
4384 unsigned long int retsts;
4388 for (info = open_pipes; info != NULL; last = info, info = info->next)
4389 if (info->fp == fp) break;
4391 if (info == NULL) { /* no such pipe open */
4392 set_errno(ECHILD); /* quoth POSIX */
4393 set_vaxc_errno(SS$_NONEXPR);
4397 /* If we were writing to a subprocess, insure that someone reading from
4398 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4399 * produce an EOF record in the mailbox.
4401 * well, at least sometimes it *does*, so we have to watch out for
4402 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4406 #if defined(USE_ITHREADS)
4409 && PL_perlio_fd_refcnt)
4410 PerlIO_flush(info->fp);
4412 fflush((FILE *)info->fp);
4415 _ckvmssts(sys$setast(0));
4416 info->closing = TRUE;
4417 done = info->done && info->in_done && info->out_done && info->err_done;
4418 /* hanging on write to Perl's input? cancel it */
4419 if (info->mode == 'r' && info->out && !info->out_done) {
4420 if (info->out->chan_out) {
4421 _ckvmssts(sys$cancel(info->out->chan_out));
4422 if (!info->out->chan_in) { /* EOF generation, need AST */
4423 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4427 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4428 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4430 _ckvmssts(sys$setast(1));
4433 #if defined(USE_ITHREADS)
4436 && PL_perlio_fd_refcnt)
4437 PerlIO_close(info->fp);
4439 fclose((FILE *)info->fp);
4442 we have to wait until subprocess completes, but ALSO wait until all
4443 the i/o completes...otherwise we'll be freeing the "info" structure
4444 that the i/o ASTs could still be using...
4448 _ckvmssts(sys$setast(0));
4449 done = info->done && info->in_done && info->out_done && info->err_done;
4450 if (!done) _ckvmssts(sys$clref(pipe_ef));
4451 _ckvmssts(sys$setast(1));
4452 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4454 retsts = info->completion;
4456 /* remove from list of open pipes */
4457 _ckvmssts(sys$setast(0));
4458 if (last) last->next = info->next;
4459 else open_pipes = info->next;
4460 _ckvmssts(sys$setast(1));
4462 /* free buffers and structures */
4465 if (info->in->buf) {
4466 n = info->in->bufsize * sizeof(char);
4467 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4470 _ckvmssts(lib$free_vm(&n, &info->in));
4473 if (info->out->buf) {
4474 n = info->out->bufsize * sizeof(char);
4475 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4478 _ckvmssts(lib$free_vm(&n, &info->out));
4481 if (info->err->buf) {
4482 n = info->err->bufsize * sizeof(char);
4483 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4486 _ckvmssts(lib$free_vm(&n, &info->err));
4489 _ckvmssts(lib$free_vm(&n, &info));
4493 } /* end of my_pclose() */
4495 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4496 /* Roll our own prototype because we want this regardless of whether
4497 * _VMS_WAIT is defined.
4499 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4501 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4502 created with popen(); otherwise partially emulate waitpid() unless
4503 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4504 Also check processes not considered by the CRTL waitpid().
4506 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4508 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4515 if (statusp) *statusp = 0;
4517 for (info = open_pipes; info != NULL; info = info->next)
4518 if (info->pid == pid) break;
4520 if (info != NULL) { /* we know about this child */
4521 while (!info->done) {
4522 _ckvmssts(sys$setast(0));
4524 if (!done) _ckvmssts(sys$clref(pipe_ef));
4525 _ckvmssts(sys$setast(1));
4526 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4529 if (statusp) *statusp = info->completion;
4533 /* child that already terminated? */
4535 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4536 if (closed_list[j].pid == pid) {
4537 if (statusp) *statusp = closed_list[j].completion;
4542 /* fall through if this child is not one of our own pipe children */
4544 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4546 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4547 * in 7.2 did we get a version that fills in the VMS completion
4548 * status as Perl has always tried to do.
4551 sts = __vms_waitpid( pid, statusp, flags );
4553 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4556 /* If the real waitpid tells us the child does not exist, we
4557 * fall through here to implement waiting for a child that
4558 * was created by some means other than exec() (say, spawned
4559 * from DCL) or to wait for a process that is not a subprocess
4560 * of the current process.
4563 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4566 $DESCRIPTOR(intdsc,"0 00:00:01");
4567 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4568 unsigned long int pidcode = JPI$_PID, mypid;
4569 unsigned long int interval[2];
4570 unsigned int jpi_iosb[2];
4571 struct itmlst_3 jpilist[2] = {
4572 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4577 /* Sorry folks, we don't presently implement rooting around for
4578 the first child we can find, and we definitely don't want to
4579 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4585 /* Get the owner of the child so I can warn if it's not mine. If the
4586 * process doesn't exist or I don't have the privs to look at it,
4587 * I can go home early.
4589 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4590 if (sts & 1) sts = jpi_iosb[0];
4602 set_vaxc_errno(sts);
4606 if (ckWARN(WARN_EXEC)) {
4607 /* remind folks they are asking for non-standard waitpid behavior */
4608 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4609 if (ownerpid != mypid)
4610 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4611 "waitpid: process %x is not a child of process %x",
4615 /* simply check on it once a second until it's not there anymore. */
4617 _ckvmssts(sys$bintim(&intdsc,interval));
4618 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4619 _ckvmssts(sys$schdwk(0,0,interval,0));
4620 _ckvmssts(sys$hiber());
4622 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4627 } /* end of waitpid() */
4632 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4634 my_gconvert(double val, int ndig, int trail, char *buf)
4636 static char __gcvtbuf[DBL_DIG+1];
4639 loc = buf ? buf : __gcvtbuf;
4641 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4643 sprintf(loc,"%.*g",ndig,val);
4649 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4650 return gcvt(val,ndig,loc);
4653 loc[0] = '0'; loc[1] = '\0';
4660 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4661 static int rms_free_search_context(struct FAB * fab)
4665 nam = fab->fab$l_nam;
4666 nam->nam$b_nop |= NAM$M_SYNCHK;
4667 nam->nam$l_rlf = NULL;
4669 return sys$parse(fab, NULL, NULL);
4672 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4673 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4674 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4675 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4676 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4677 #define rms_nam_esll(nam) nam.nam$b_esl
4678 #define rms_nam_esl(nam) nam.nam$b_esl
4679 #define rms_nam_name(nam) nam.nam$l_name
4680 #define rms_nam_namel(nam) nam.nam$l_name
4681 #define rms_nam_type(nam) nam.nam$l_type
4682 #define rms_nam_typel(nam) nam.nam$l_type
4683 #define rms_nam_ver(nam) nam.nam$l_ver
4684 #define rms_nam_verl(nam) nam.nam$l_ver
4685 #define rms_nam_rsll(nam) nam.nam$b_rsl
4686 #define rms_nam_rsl(nam) nam.nam$b_rsl
4687 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4688 #define rms_set_fna(fab, nam, name, size) \
4689 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4690 #define rms_get_fna(fab, nam) fab.fab$l_fna
4691 #define rms_set_dna(fab, nam, name, size) \
4692 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4693 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4694 #define rms_set_esa(fab, nam, name, size) \
4695 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4696 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4697 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4698 #define rms_set_rsa(nam, name, size) \
4699 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4700 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4701 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4702 #define rms_nam_name_type_l_size(nam) \
4703 (nam.nam$b_name + nam.nam$b_type)
4705 static int rms_free_search_context(struct FAB * fab)
4709 nam = fab->fab$l_naml;
4710 nam->naml$b_nop |= NAM$M_SYNCHK;
4711 nam->naml$l_rlf = NULL;
4712 nam->naml$l_long_defname_size = 0;
4715 return sys$parse(fab, NULL, NULL);
4718 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4719 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4720 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4721 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4722 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4723 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4724 #define rms_nam_esl(nam) nam.naml$b_esl
4725 #define rms_nam_name(nam) nam.naml$l_name
4726 #define rms_nam_namel(nam) nam.naml$l_long_name
4727 #define rms_nam_type(nam) nam.naml$l_type
4728 #define rms_nam_typel(nam) nam.naml$l_long_type
4729 #define rms_nam_ver(nam) nam.naml$l_ver
4730 #define rms_nam_verl(nam) nam.naml$l_long_ver
4731 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4732 #define rms_nam_rsl(nam) nam.naml$b_rsl
4733 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4734 #define rms_set_fna(fab, nam, name, size) \
4735 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4736 nam.naml$l_long_filename_size = size; \
4737 nam.naml$l_long_filename = name;}
4738 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4739 #define rms_set_dna(fab, nam, name, size) \
4740 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4741 nam.naml$l_long_defname_size = size; \
4742 nam.naml$l_long_defname = name; }
4743 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4744 #define rms_set_esa(fab, nam, name, size) \
4745 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4746 nam.naml$l_long_expand_alloc = size; \
4747 nam.naml$l_long_expand = name; }
4748 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4749 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4750 nam.naml$l_long_expand = l_name; \
4751 nam.naml$l_long_expand_alloc = l_size; }
4752 #define rms_set_rsa(nam, name, size) \
4753 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4754 nam.naml$l_long_result = name; \
4755 nam.naml$l_long_result_alloc = size; }
4756 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4757 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4758 nam.naml$l_long_result = l_name; \
4759 nam.naml$l_long_result_alloc = l_size; }
4760 #define rms_nam_name_type_l_size(nam) \
4761 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4765 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4766 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4767 * to expand file specification. Allows for a single default file
4768 * specification and a simple mask of options. If outbuf is non-NULL,
4769 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4770 * the resultant file specification is placed. If outbuf is NULL, the
4771 * resultant file specification is placed into a static buffer.
4772 * The third argument, if non-NULL, is taken to be a default file
4773 * specification string. The fourth argument is unused at present.
4774 * rmesexpand() returns the address of the resultant string if
4775 * successful, and NULL on error.
4777 * New functionality for previously unused opts value:
4778 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4779 * PERL_RMSEXPAND_M_LONG - Want output in long formst
4780 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4782 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4786 (pTHX_ const char *filespec,
4789 const char *defspec,
4794 static char __rmsexpand_retbuf[VMS_MAXRSS];
4795 char * vmsfspec, *tmpfspec;
4796 char * esa, *cp, *out = NULL;
4800 struct FAB myfab = cc$rms_fab;
4801 rms_setup_nam(mynam);
4803 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4806 /* temp hack until UTF8 is actually implemented */
4807 if (fs_utf8 != NULL)
4810 if (!filespec || !*filespec) {
4811 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4815 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4816 else outbuf = __rmsexpand_retbuf;
4824 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4825 isunix = is_unix_filespec(filespec);
4827 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4828 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4829 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4830 PerlMem_free(vmsfspec);
4835 filespec = vmsfspec;
4837 /* Unless we are forcing to VMS format, a UNIX input means
4838 * UNIX output, and that requires long names to be used
4840 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4841 opts |= PERL_RMSEXPAND_M_LONG;
4848 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4849 rms_bind_fab_nam(myfab, mynam);
4851 if (defspec && *defspec) {
4853 t_isunix = is_unix_filespec(defspec);
4855 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4856 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4857 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4858 PerlMem_free(tmpfspec);
4859 if (vmsfspec != NULL)
4860 PerlMem_free(vmsfspec);
4867 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4870 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4871 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4872 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4873 esal = PerlMem_malloc(VMS_MAXRSS);
4874 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4876 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4878 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4879 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4882 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4883 outbufl = PerlMem_malloc(VMS_MAXRSS);
4884 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4885 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4887 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4891 #ifdef NAM$M_NO_SHORT_UPCASE
4892 if (decc_efs_case_preserve)
4893 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4896 /* First attempt to parse as an existing file */
4897 retsts = sys$parse(&myfab,0,0);
4898 if (!(retsts & STS$K_SUCCESS)) {
4900 /* Could not find the file, try as syntax only if error is not fatal */
4901 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4902 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4903 retsts = sys$parse(&myfab,0,0);
4904 if (retsts & STS$K_SUCCESS) goto expanded;
4907 /* Still could not parse the file specification */
4908 /*----------------------------------------------*/
4909 sts = rms_free_search_context(&myfab); /* Free search context */
4910 if (out) Safefree(out);
4911 if (tmpfspec != NULL)
4912 PerlMem_free(tmpfspec);
4913 if (vmsfspec != NULL)
4914 PerlMem_free(vmsfspec);
4915 if (outbufl != NULL)
4916 PerlMem_free(outbufl);
4920 set_vaxc_errno(retsts);
4921 if (retsts == RMS$_PRV) set_errno(EACCES);
4922 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4923 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4924 else set_errno(EVMSERR);
4927 retsts = sys$search(&myfab,0,0);
4928 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4929 sts = rms_free_search_context(&myfab); /* Free search context */
4930 if (out) Safefree(out);
4931 if (tmpfspec != NULL)
4932 PerlMem_free(tmpfspec);
4933 if (vmsfspec != NULL)
4934 PerlMem_free(vmsfspec);
4935 if (outbufl != NULL)
4936 PerlMem_free(outbufl);
4940 set_vaxc_errno(retsts);
4941 if (retsts == RMS$_PRV) set_errno(EACCES);
4942 else set_errno(EVMSERR);
4946 /* If the input filespec contained any lowercase characters,
4947 * downcase the result for compatibility with Unix-minded code. */
4949 if (!decc_efs_case_preserve) {
4950 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4951 if (islower(*tbuf)) { haslower = 1; break; }
4954 /* Is a long or a short name expected */
4955 /*------------------------------------*/
4956 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4957 if (rms_nam_rsll(mynam)) {
4959 speclen = rms_nam_rsll(mynam);
4962 tbuf = esal; /* Not esa */
4963 speclen = rms_nam_esll(mynam);
4967 if (rms_nam_rsl(mynam)) {
4969 speclen = rms_nam_rsl(mynam);
4972 tbuf = esa; /* Not esal */
4973 speclen = rms_nam_esl(mynam);
4976 tbuf[speclen] = '\0';
4978 /* Trim off null fields added by $PARSE
4979 * If type > 1 char, must have been specified in original or default spec
4980 * (not true for version; $SEARCH may have added version of existing file).
4982 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4983 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4984 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4985 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4988 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4989 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4991 if (trimver || trimtype) {
4992 if (defspec && *defspec) {
4993 char *defesal = NULL;
4994 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
4995 if (defesal != NULL) {
4996 struct FAB deffab = cc$rms_fab;
4997 rms_setup_nam(defnam);
4999 rms_bind_fab_nam(deffab, defnam);
5003 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5005 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
5007 rms_clear_nam_nop(defnam);
5008 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5009 #ifdef NAM$M_NO_SHORT_UPCASE
5010 if (decc_efs_case_preserve)
5011 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5013 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5015 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5018 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5021 PerlMem_free(defesal);
5025 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5026 if (*(rms_nam_verl(mynam)) != '\"')
5027 speclen = rms_nam_verl(mynam) - tbuf;
5030 if (*(rms_nam_ver(mynam)) != '\"')
5031 speclen = rms_nam_ver(mynam) - tbuf;
5035 /* If we didn't already trim version, copy down */
5036 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5037 if (speclen > rms_nam_verl(mynam) - tbuf)
5039 (rms_nam_typel(mynam),
5040 rms_nam_verl(mynam),
5041 speclen - (rms_nam_verl(mynam) - tbuf));
5042 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5045 if (speclen > rms_nam_ver(mynam) - tbuf)
5047 (rms_nam_type(mynam),
5049 speclen - (rms_nam_ver(mynam) - tbuf));
5050 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5055 /* Done with these copies of the input files */
5056 /*-------------------------------------------*/
5057 if (vmsfspec != NULL)
5058 PerlMem_free(vmsfspec);
5059 if (tmpfspec != NULL)
5060 PerlMem_free(tmpfspec);
5062 /* If we just had a directory spec on input, $PARSE "helpfully"
5063 * adds an empty name and type for us */
5064 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5065 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5066 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5067 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5068 speclen = rms_nam_namel(mynam) - tbuf;
5071 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5072 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5073 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5074 speclen = rms_nam_name(mynam) - tbuf;
5077 /* Posix format specifications must have matching quotes */
5078 if (speclen < (VMS_MAXRSS - 1)) {
5079 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5080 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5081 tbuf[speclen] = '\"';
5086 tbuf[speclen] = '\0';
5087 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5089 /* Have we been working with an expanded, but not resultant, spec? */
5090 /* Also, convert back to Unix syntax if necessary. */
5092 if (!rms_nam_rsll(mynam)) {
5094 if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
5095 if (out) Safefree(out);
5099 if (outbufl != NULL)
5100 PerlMem_free(outbufl);
5104 else strcpy(outbuf,esa);
5107 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5108 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5109 if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5110 if (out) Safefree(out);
5114 PerlMem_free(tmpfspec);
5115 if (outbufl != NULL)
5116 PerlMem_free(outbufl);
5119 strcpy(outbuf,tmpfspec);
5120 PerlMem_free(tmpfspec);
5123 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5124 sts = rms_free_search_context(&myfab); /* Free search context */
5128 if (outbufl != NULL)
5129 PerlMem_free(outbufl);
5133 /* External entry points */
5134 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5135 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5136 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5137 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5138 char *Perl_rmsexpand_utf8
5139 (pTHX_ const char *spec, char *buf, const char *def,
5140 unsigned opt, int * fs_utf8, int * dfs_utf8)
5141 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5142 char *Perl_rmsexpand_utf8_ts
5143 (pTHX_ const char *spec, char *buf, const char *def,
5144 unsigned opt, int * fs_utf8, int * dfs_utf8)
5145 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5149 ** The following routines are provided to make life easier when
5150 ** converting among VMS-style and Unix-style directory specifications.
5151 ** All will take input specifications in either VMS or Unix syntax. On
5152 ** failure, all return NULL. If successful, the routines listed below
5153 ** return a pointer to a buffer containing the appropriately
5154 ** reformatted spec (and, therefore, subsequent calls to that routine
5155 ** will clobber the result), while the routines of the same names with
5156 ** a _ts suffix appended will return a pointer to a mallocd string
5157 ** containing the appropriately reformatted spec.
5158 ** In all cases, only explicit syntax is altered; no check is made that
5159 ** the resulting string is valid or that the directory in question
5162 ** fileify_dirspec() - convert a directory spec into the name of the
5163 ** directory file (i.e. what you can stat() to see if it's a dir).
5164 ** The style (VMS or Unix) of the result is the same as the style
5165 ** of the parameter passed in.
5166 ** pathify_dirspec() - convert a directory spec into a path (i.e.
5167 ** what you prepend to a filename to indicate what directory it's in).
5168 ** The style (VMS or Unix) of the result is the same as the style
5169 ** of the parameter passed in.
5170 ** tounixpath() - convert a directory spec into a Unix-style path.
5171 ** tovmspath() - convert a directory spec into a VMS-style path.
5172 ** tounixspec() - convert any file spec into a Unix-style file spec.
5173 ** tovmsspec() - convert any file spec into a VMS-style spec.
5174 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5176 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
5177 ** Permission is given to distribute this code as part of the Perl
5178 ** standard distribution under the terms of the GNU General Public
5179 ** License or the Perl Artistic License. Copies of each may be
5180 ** found in the Perl standard distribution.
5183 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5184 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5186 static char __fileify_retbuf[VMS_MAXRSS];
5187 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5188 char *retspec, *cp1, *cp2, *lastdir;
5189 char *trndir, *vmsdir;
5190 unsigned short int trnlnm_iter_count;
5192 if (utf8_fl != NULL)
5195 if (!dir || !*dir) {
5196 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5198 dirlen = strlen(dir);
5199 while (dirlen && dir[dirlen-1] == '/') --dirlen;
5200 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5201 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5208 if (dirlen > (VMS_MAXRSS - 1)) {
5209 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5212 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5213 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5214 if (!strpbrk(dir+1,"/]>:") &&
5215 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5216 strcpy(trndir,*dir == '/' ? dir + 1: dir);
5217 trnlnm_iter_count = 0;
5218 while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5219 trnlnm_iter_count++;
5220 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5222 dirlen = strlen(trndir);
5225 strncpy(trndir,dir,dirlen);
5226 trndir[dirlen] = '\0';
5229 /* At this point we are done with *dir and use *trndir which is a
5230 * copy that can be modified. *dir must not be modified.
5233 /* If we were handed a rooted logical name or spec, treat it like a
5234 * simple directory, so that
5235 * $ Define myroot dev:[dir.]
5236 * ... do_fileify_dirspec("myroot",buf,1) ...
5237 * does something useful.
5239 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5240 trndir[--dirlen] = '\0';
5241 trndir[dirlen-1] = ']';
5243 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5244 trndir[--dirlen] = '\0';
5245 trndir[dirlen-1] = '>';
5248 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5249 /* If we've got an explicit filename, we can just shuffle the string. */
5250 if (*(cp1+1)) hasfilename = 1;
5251 /* Similarly, we can just back up a level if we've got multiple levels
5252 of explicit directories in a VMS spec which ends with directories. */
5254 for (cp2 = cp1; cp2 > trndir; cp2--) {
5256 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5257 /* fix-me, can not scan EFS file specs backward like this */
5258 *cp2 = *cp1; *cp1 = '\0';
5263 if (*cp2 == '[' || *cp2 == '<') break;
5268 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5269 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5270 cp1 = strpbrk(trndir,"]:>");
5271 if (hasfilename || !cp1) { /* Unix-style path or filename */
5272 if (trndir[0] == '.') {
5273 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5274 PerlMem_free(trndir);
5275 PerlMem_free(vmsdir);
5276 return do_fileify_dirspec("[]",buf,ts,NULL);
5278 else if (trndir[1] == '.' &&
5279 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5280 PerlMem_free(trndir);
5281 PerlMem_free(vmsdir);
5282 return do_fileify_dirspec("[-]",buf,ts,NULL);
5285 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
5286 dirlen -= 1; /* to last element */
5287 lastdir = strrchr(trndir,'/');
5289 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5290 /* If we have "/." or "/..", VMSify it and let the VMS code
5291 * below expand it, rather than repeating the code to handle
5292 * relative components of a filespec here */
5294 if (*(cp1+2) == '.') cp1++;
5295 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5297 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5298 PerlMem_free(trndir);
5299 PerlMem_free(vmsdir);
5302 if (strchr(vmsdir,'/') != NULL) {
5303 /* If do_tovmsspec() returned it, it must have VMS syntax
5304 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5305 * the time to check this here only so we avoid a recursion
5306 * loop; otherwise, gigo.
5308 PerlMem_free(trndir);
5309 PerlMem_free(vmsdir);
5310 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5313 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5314 PerlMem_free(trndir);
5315 PerlMem_free(vmsdir);
5318 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5319 PerlMem_free(trndir);
5320 PerlMem_free(vmsdir);
5324 } while ((cp1 = strstr(cp1,"/.")) != NULL);
5325 lastdir = strrchr(trndir,'/');
5327 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5329 /* Ditto for specs that end in an MFD -- let the VMS code
5330 * figure out whether it's a real device or a rooted logical. */
5332 /* This should not happen any more. Allowing the fake /000000
5333 * in a UNIX pathname causes all sorts of problems when trying
5334 * to run in UNIX emulation. So the VMS to UNIX conversions
5335 * now remove the fake /000000 directories.
5338 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5339 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5340 PerlMem_free(trndir);
5341 PerlMem_free(vmsdir);
5344 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5345 PerlMem_free(trndir);
5346 PerlMem_free(vmsdir);
5349 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5350 PerlMem_free(trndir);
5351 PerlMem_free(vmsdir);
5356 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5357 !(lastdir = cp1 = strrchr(trndir,']')) &&
5358 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5359 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
5362 /* For EFS or ODS-5 look for the last dot */
5363 if (decc_efs_charset) {
5364 cp2 = strrchr(cp1,'.');
5366 if (vms_process_case_tolerant) {
5367 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5368 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5369 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5370 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5371 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5372 (ver || *cp3)))))) {
5373 PerlMem_free(trndir);
5374 PerlMem_free(vmsdir);
5376 set_vaxc_errno(RMS$_DIR);
5381 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5382 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5383 !*(cp2+3) || *(cp2+3) != 'R' ||
5384 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5385 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5386 (ver || *cp3)))))) {
5387 PerlMem_free(trndir);
5388 PerlMem_free(vmsdir);
5390 set_vaxc_errno(RMS$_DIR);
5394 dirlen = cp2 - trndir;
5398 retlen = dirlen + 6;
5399 if (buf) retspec = buf;
5400 else if (ts) Newx(retspec,retlen+1,char);
5401 else retspec = __fileify_retbuf;
5402 memcpy(retspec,trndir,dirlen);
5403 retspec[dirlen] = '\0';
5405 /* We've picked up everything up to the directory file name.
5406 Now just add the type and version, and we're set. */
5407 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5408 strcat(retspec,".dir;1");
5410 strcat(retspec,".DIR;1");
5411 PerlMem_free(trndir);
5412 PerlMem_free(vmsdir);
5415 else { /* VMS-style directory spec */
5417 char *esa, term, *cp;
5418 unsigned long int sts, cmplen, haslower = 0;
5419 unsigned int nam_fnb;
5421 struct FAB dirfab = cc$rms_fab;
5422 rms_setup_nam(savnam);
5423 rms_setup_nam(dirnam);
5425 esa = PerlMem_malloc(VMS_MAXRSS + 1);
5426 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5427 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5428 rms_bind_fab_nam(dirfab, dirnam);
5429 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5430 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5431 #ifdef NAM$M_NO_SHORT_UPCASE
5432 if (decc_efs_case_preserve)
5433 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5436 for (cp = trndir; *cp; cp++)
5437 if (islower(*cp)) { haslower = 1; break; }
5438 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5439 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5440 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5441 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5445 PerlMem_free(trndir);
5446 PerlMem_free(vmsdir);
5448 set_vaxc_errno(dirfab.fab$l_sts);
5454 /* Does the file really exist? */
5455 if (sys$search(&dirfab)& STS$K_SUCCESS) {
5456 /* Yes; fake the fnb bits so we'll check type below */
5457 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5459 else { /* No; just work with potential name */
5460 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5463 fab_sts = dirfab.fab$l_sts;
5464 sts = rms_free_search_context(&dirfab);
5466 PerlMem_free(trndir);
5467 PerlMem_free(vmsdir);
5468 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
5473 esa[rms_nam_esll(dirnam)] = '\0';
5474 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5475 cp1 = strchr(esa,']');
5476 if (!cp1) cp1 = strchr(esa,'>');
5477 if (cp1) { /* Should always be true */
5478 rms_nam_esll(dirnam) -= cp1 - esa - 1;
5479 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5482 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5483 /* Yep; check version while we're at it, if it's there. */
5484 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5485 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5486 /* Something other than .DIR[;1]. Bzzt. */
5487 sts = rms_free_search_context(&dirfab);
5489 PerlMem_free(trndir);
5490 PerlMem_free(vmsdir);
5492 set_vaxc_errno(RMS$_DIR);
5497 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5498 /* They provided at least the name; we added the type, if necessary, */
5499 if (buf) retspec = buf; /* in sys$parse() */
5500 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5501 else retspec = __fileify_retbuf;
5502 strcpy(retspec,esa);
5503 sts = rms_free_search_context(&dirfab);
5504 PerlMem_free(trndir);
5506 PerlMem_free(vmsdir);
5509 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5510 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5512 rms_nam_esll(dirnam) -= 9;
5514 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5515 if (cp1 == NULL) { /* should never happen */
5516 sts = rms_free_search_context(&dirfab);
5517 PerlMem_free(trndir);
5519 PerlMem_free(vmsdir);
5524 retlen = strlen(esa);
5525 cp1 = strrchr(esa,'.');
5526 /* ODS-5 directory specifications can have extra "." in them. */
5527 /* Fix-me, can not scan EFS file specifications backwards */
5528 while (cp1 != NULL) {
5529 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5533 while ((cp1 > esa) && (*cp1 != '.'))
5540 if ((cp1) != NULL) {
5541 /* There's more than one directory in the path. Just roll back. */
5543 if (buf) retspec = buf;
5544 else if (ts) Newx(retspec,retlen+7,char);
5545 else retspec = __fileify_retbuf;
5546 strcpy(retspec,esa);
5549 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5550 /* Go back and expand rooted logical name */
5551 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5552 #ifdef NAM$M_NO_SHORT_UPCASE
5553 if (decc_efs_case_preserve)
5554 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5556 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5557 sts = rms_free_search_context(&dirfab);
5559 PerlMem_free(trndir);
5560 PerlMem_free(vmsdir);
5562 set_vaxc_errno(dirfab.fab$l_sts);
5565 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5566 if (buf) retspec = buf;
5567 else if (ts) Newx(retspec,retlen+16,char);
5568 else retspec = __fileify_retbuf;
5569 cp1 = strstr(esa,"][");
5570 if (!cp1) cp1 = strstr(esa,"]<");
5572 memcpy(retspec,esa,dirlen);
5573 if (!strncmp(cp1+2,"000000]",7)) {
5574 retspec[dirlen-1] = '\0';
5575 /* fix-me Not full ODS-5, just extra dots in directories for now */
5576 cp1 = retspec + dirlen - 1;
5577 while (cp1 > retspec)
5582 if (*(cp1-1) != '^')
5587 if (*cp1 == '.') *cp1 = ']';
5589 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5590 memmove(cp1+1,"000000]",7);
5594 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5595 retspec[retlen] = '\0';
5596 /* Convert last '.' to ']' */
5597 cp1 = retspec+retlen-1;
5598 while (*cp != '[') {
5601 /* Do not trip on extra dots in ODS-5 directories */
5602 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5606 if (*cp1 == '.') *cp1 = ']';
5608 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5609 memmove(cp1+1,"000000]",7);
5613 else { /* This is a top-level dir. Add the MFD to the path. */
5614 if (buf) retspec = buf;
5615 else if (ts) Newx(retspec,retlen+16,char);
5616 else retspec = __fileify_retbuf;
5619 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5620 strcpy(cp2,":[000000]");
5625 sts = rms_free_search_context(&dirfab);
5626 /* We've set up the string up through the filename. Add the
5627 type and version, and we're done. */
5628 strcat(retspec,".DIR;1");
5630 /* $PARSE may have upcased filespec, so convert output to lower
5631 * case if input contained any lowercase characters. */
5632 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5633 PerlMem_free(trndir);
5635 PerlMem_free(vmsdir);
5638 } /* end of do_fileify_dirspec() */
5640 /* External entry points */
5641 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5642 { return do_fileify_dirspec(dir,buf,0,NULL); }
5643 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5644 { return do_fileify_dirspec(dir,buf,1,NULL); }
5645 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5646 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5647 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5648 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5650 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5651 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5653 static char __pathify_retbuf[VMS_MAXRSS];
5654 unsigned long int retlen;
5655 char *retpath, *cp1, *cp2, *trndir;
5656 unsigned short int trnlnm_iter_count;
5659 if (utf8_fl != NULL)
5662 if (!dir || !*dir) {
5663 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5666 trndir = PerlMem_malloc(VMS_MAXRSS);
5667 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5668 if (*dir) strcpy(trndir,dir);
5669 else getcwd(trndir,VMS_MAXRSS - 1);
5671 trnlnm_iter_count = 0;
5672 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5673 && my_trnlnm(trndir,trndir,0)) {
5674 trnlnm_iter_count++;
5675 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5676 trnlen = strlen(trndir);
5678 /* Trap simple rooted lnms, and return lnm:[000000] */
5679 if (!strcmp(trndir+trnlen-2,".]")) {
5680 if (buf) retpath = buf;
5681 else if (ts) Newx(retpath,strlen(dir)+10,char);
5682 else retpath = __pathify_retbuf;
5683 strcpy(retpath,dir);
5684 strcat(retpath,":[000000]");
5685 PerlMem_free(trndir);
5690 /* At this point we do not work with *dir, but the copy in
5691 * *trndir that is modifiable.
5694 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5695 if (*trndir == '.' && (*(trndir+1) == '\0' ||
5696 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5697 retlen = 2 + (*(trndir+1) != '\0');
5699 if ( !(cp1 = strrchr(trndir,'/')) &&
5700 !(cp1 = strrchr(trndir,']')) &&
5701 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5702 if ((cp2 = strchr(cp1,'.')) != NULL &&
5703 (*(cp2-1) != '/' || /* Trailing '.', '..', */
5704 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
5705 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5706 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5709 /* For EFS or ODS-5 look for the last dot */
5710 if (decc_efs_charset) {
5711 cp2 = strrchr(cp1,'.');
5713 if (vms_process_case_tolerant) {
5714 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5715 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5716 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5717 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5718 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5719 (ver || *cp3)))))) {
5720 PerlMem_free(trndir);
5722 set_vaxc_errno(RMS$_DIR);
5727 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5728 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5729 !*(cp2+3) || *(cp2+3) != 'R' ||
5730 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5731 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5732 (ver || *cp3)))))) {
5733 PerlMem_free(trndir);
5735 set_vaxc_errno(RMS$_DIR);
5739 retlen = cp2 - trndir + 1;
5741 else { /* No file type present. Treat the filename as a directory. */
5742 retlen = strlen(trndir) + 1;
5745 if (buf) retpath = buf;
5746 else if (ts) Newx(retpath,retlen+1,char);
5747 else retpath = __pathify_retbuf;
5748 strncpy(retpath, trndir, retlen-1);
5749 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5750 retpath[retlen-1] = '/'; /* with '/', add it. */
5751 retpath[retlen] = '\0';
5753 else retpath[retlen-1] = '\0';
5755 else { /* VMS-style directory spec */
5757 unsigned long int sts, cmplen, haslower;
5758 struct FAB dirfab = cc$rms_fab;
5760 rms_setup_nam(savnam);
5761 rms_setup_nam(dirnam);
5763 /* If we've got an explicit filename, we can just shuffle the string. */
5764 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5765 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
5766 if ((cp2 = strchr(cp1,'.')) != NULL) {
5768 if (vms_process_case_tolerant) {
5769 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5770 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5771 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5772 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5773 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5774 (ver || *cp3)))))) {
5775 PerlMem_free(trndir);
5777 set_vaxc_errno(RMS$_DIR);
5782 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5783 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5784 !*(cp2+3) || *(cp2+3) != 'R' ||
5785 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5786 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5787 (ver || *cp3)))))) {
5788 PerlMem_free(trndir);
5790 set_vaxc_errno(RMS$_DIR);
5795 else { /* No file type, so just draw name into directory part */
5796 for (cp2 = cp1; *cp2; cp2++) ;
5799 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5801 /* We've now got a VMS 'path'; fall through */
5804 dirlen = strlen(trndir);
5805 if (trndir[dirlen-1] == ']' ||
5806 trndir[dirlen-1] == '>' ||
5807 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5808 if (buf) retpath = buf;
5809 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5810 else retpath = __pathify_retbuf;
5811 strcpy(retpath,trndir);
5812 PerlMem_free(trndir);
5815 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5816 esa = PerlMem_malloc(VMS_MAXRSS);
5817 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5818 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5819 rms_bind_fab_nam(dirfab, dirnam);
5820 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5821 #ifdef NAM$M_NO_SHORT_UPCASE
5822 if (decc_efs_case_preserve)
5823 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5826 for (cp = trndir; *cp; cp++)
5827 if (islower(*cp)) { haslower = 1; break; }
5829 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5830 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5831 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5832 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5835 PerlMem_free(trndir);
5838 set_vaxc_errno(dirfab.fab$l_sts);
5844 /* Does the file really exist? */
5845 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5846 if (dirfab.fab$l_sts != RMS$_FNF) {
5848 sts1 = rms_free_search_context(&dirfab);
5849 PerlMem_free(trndir);
5852 set_vaxc_errno(dirfab.fab$l_sts);
5855 dirnam = savnam; /* No; just work with potential name */
5858 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5859 /* Yep; check version while we're at it, if it's there. */
5860 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5861 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5863 /* Something other than .DIR[;1]. Bzzt. */
5864 sts2 = rms_free_search_context(&dirfab);
5865 PerlMem_free(trndir);
5868 set_vaxc_errno(RMS$_DIR);
5872 /* OK, the type was fine. Now pull any file name into the
5874 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5876 cp1 = strrchr(esa,'>');
5877 *(rms_nam_typel(dirnam)) = '>';
5880 *(rms_nam_typel(dirnam) + 1) = '\0';
5881 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5882 if (buf) retpath = buf;
5883 else if (ts) Newx(retpath,retlen,char);
5884 else retpath = __pathify_retbuf;
5885 strcpy(retpath,esa);
5887 sts = rms_free_search_context(&dirfab);
5888 /* $PARSE may have upcased filespec, so convert output to lower
5889 * case if input contained any lowercase characters. */
5890 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5893 PerlMem_free(trndir);
5895 } /* end of do_pathify_dirspec() */
5897 /* External entry points */
5898 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5899 { return do_pathify_dirspec(dir,buf,0,NULL); }
5900 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5901 { return do_pathify_dirspec(dir,buf,1,NULL); }
5902 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5903 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5904 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5905 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5907 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5908 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5910 static char __tounixspec_retbuf[VMS_MAXRSS];
5911 char *dirend, *rslt, *cp1, *cp3, *tmp;
5913 int devlen, dirlen, retlen = VMS_MAXRSS;
5914 int expand = 1; /* guarantee room for leading and trailing slashes */
5915 unsigned short int trnlnm_iter_count;
5917 if (utf8_fl != NULL)
5920 if (spec == NULL) return NULL;
5921 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5922 if (buf) rslt = buf;
5924 Newx(rslt, VMS_MAXRSS, char);
5926 else rslt = __tounixspec_retbuf;
5928 /* New VMS specific format needs translation
5929 * glob passes filenames with trailing '\n' and expects this preserved.
5931 if (decc_posix_compliant_pathnames) {
5932 if (strncmp(spec, "\"^UP^", 5) == 0) {
5938 tunix = PerlMem_malloc(VMS_MAXRSS);
5939 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5940 strcpy(tunix, spec);
5941 tunix_len = strlen(tunix);
5943 if (tunix[tunix_len - 1] == '\n') {
5944 tunix[tunix_len - 1] = '\"';
5945 tunix[tunix_len] = '\0';
5949 uspec = decc$translate_vms(tunix);
5950 PerlMem_free(tunix);
5951 if ((int)uspec > 0) {
5957 /* If we can not translate it, makemaker wants as-is */
5965 cmp_rslt = 0; /* Presume VMS */
5966 cp1 = strchr(spec, '/');
5970 /* Look for EFS ^/ */
5971 if (decc_efs_charset) {
5972 while (cp1 != NULL) {
5975 /* Found illegal VMS, assume UNIX */
5980 cp1 = strchr(cp1, '/');
5984 /* Look for "." and ".." */
5985 if (decc_filename_unix_report) {
5986 if (spec[0] == '.') {
5987 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5991 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5997 /* This is already UNIX or at least nothing VMS understands */
6005 dirend = strrchr(spec,']');
6006 if (dirend == NULL) dirend = strrchr(spec,'>');
6007 if (dirend == NULL) dirend = strchr(spec,':');
6008 if (dirend == NULL) {
6013 /* Special case 1 - sys$posix_root = / */
6014 #if __CRTL_VER >= 70000000
6015 if (!decc_disable_posix_root) {
6016 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6024 /* Special case 2 - Convert NLA0: to /dev/null */
6025 #if __CRTL_VER < 70000000
6026 cmp_rslt = strncmp(spec,"NLA0:", 5);
6028 cmp_rslt = strncmp(spec,"nla0:", 5);
6030 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6032 if (cmp_rslt == 0) {
6033 strcpy(rslt, "/dev/null");
6036 if (spec[6] != '\0') {
6043 /* Also handle special case "SYS$SCRATCH:" */
6044 #if __CRTL_VER < 70000000
6045 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6047 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6049 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6051 tmp = PerlMem_malloc(VMS_MAXRSS);
6052 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6053 if (cmp_rslt == 0) {
6056 islnm = my_trnlnm(tmp, "TMP", 0);
6058 strcpy(rslt, "/tmp");
6061 if (spec[12] != '\0') {
6069 if (*cp2 != '[' && *cp2 != '<') {
6072 else { /* the VMS spec begins with directories */
6074 if (*cp2 == ']' || *cp2 == '>') {
6075 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6079 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6080 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6081 if (ts) Safefree(rslt);
6085 trnlnm_iter_count = 0;
6088 while (*cp3 != ':' && *cp3) cp3++;
6090 if (strchr(cp3,']') != NULL) break;
6091 trnlnm_iter_count++;
6092 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6093 } while (vmstrnenv(tmp,tmp,0,fildev,0));
6095 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6096 retlen = devlen + dirlen;
6097 Renew(rslt,retlen+1+2*expand,char);
6103 *(cp1++) = *(cp3++);
6104 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6106 return NULL; /* No room */
6111 if ((*cp2 == '^')) {
6112 /* EFS file escape, pass the next character as is */
6113 /* Fix me: HEX encoding for Unicode not implemented */
6116 else if ( *cp2 == '.') {
6117 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6118 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6125 for (; cp2 <= dirend; cp2++) {
6126 if ((*cp2 == '^')) {
6127 /* EFS file escape, pass the next character as is */
6128 /* Fix me: HEX encoding for Unicode not implemented */
6129 *(cp1++) = *(++cp2);
6130 /* An escaped dot stays as is -- don't convert to slash */
6131 if (*cp2 == '.') cp2++;
6135 if (*(cp2+1) == '[') cp2++;
6137 else if (*cp2 == ']' || *cp2 == '>') {
6138 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6140 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6142 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6143 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6144 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6145 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6146 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6148 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6149 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6153 else if (*cp2 == '-') {
6154 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6155 while (*cp2 == '-') {
6157 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6159 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6160 if (ts) Safefree(rslt); /* filespecs like */
6161 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
6165 else *(cp1++) = *cp2;
6167 else *(cp1++) = *cp2;
6170 if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */
6171 *(cp1++) = *(cp2++);
6175 /* This still leaves /000000/ when working with a
6176 * VMS device root or concealed root.
6182 ulen = strlen(rslt);
6184 /* Get rid of "000000/ in rooted filespecs */
6186 zeros = strstr(rslt, "/000000/");
6187 if (zeros != NULL) {
6189 mlen = ulen - (zeros - rslt) - 7;
6190 memmove(zeros, &zeros[7], mlen);
6199 } /* end of do_tounixspec() */
6201 /* External entry points */
6202 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6203 { return do_tounixspec(spec,buf,0, NULL); }
6204 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6205 { return do_tounixspec(spec,buf,1, NULL); }
6206 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6207 { return do_tounixspec(spec,buf,0, utf8_fl); }
6208 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6209 { return do_tounixspec(spec,buf,1, utf8_fl); }
6211 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6214 This procedure is used to identify if a path is based in either
6215 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6216 it returns the OpenVMS format directory for it.
6218 It is expecting specifications of only '/' or '/xxxx/'
6220 If a posix root does not exist, or 'xxxx' is not a directory
6221 in the posix root, it returns a failure.
6223 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6225 It is used only internally by posix_to_vmsspec_hardway().
6228 static int posix_root_to_vms
6229 (char *vmspath, int vmspath_len,
6230 const char *unixpath,
6231 const int * utf8_fl) {
6233 struct FAB myfab = cc$rms_fab;
6234 struct NAML mynam = cc$rms_naml;
6235 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6236 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6243 unixlen = strlen(unixpath);
6249 #if __CRTL_VER >= 80200000
6250 /* If not a posix spec already, convert it */
6251 if (decc_posix_compliant_pathnames) {
6252 if (strncmp(unixpath,"\"^UP^",5) != 0) {
6253 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6256 /* This is already a VMS specification, no conversion */
6258 strncpy(vmspath,unixpath, vmspath_len);
6267 /* Check to see if this is under the POSIX root */
6268 if (decc_disable_posix_root) {
6272 /* Skip leading / */
6273 if (unixpath[0] == '/') {
6279 strcpy(vmspath,"SYS$POSIX_ROOT:");
6281 /* If this is only the / , or blank, then... */
6282 if (unixpath[0] == '\0') {
6283 /* by definition, this is the answer */
6287 /* Need to look up a directory */
6291 /* Copy and add '^' escape characters as needed */
6294 while (unixpath[i] != 0) {
6297 j += copy_expand_unix_filename_escape
6298 (&vmspath[j], &unixpath[i], &k, utf8_fl);
6302 path_len = strlen(vmspath);
6303 if (vmspath[path_len - 1] == '/')
6305 vmspath[path_len] = ']';
6307 vmspath[path_len] = '\0';
6310 vmspath[vmspath_len] = 0;
6311 if (unixpath[unixlen - 1] == '/')
6313 esa = PerlMem_malloc(VMS_MAXRSS);
6314 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6315 myfab.fab$l_fna = vmspath;
6316 myfab.fab$b_fns = strlen(vmspath);
6317 myfab.fab$l_naml = &mynam;
6318 mynam.naml$l_esa = NULL;
6319 mynam.naml$b_ess = 0;
6320 mynam.naml$l_long_expand = esa;
6321 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6322 mynam.naml$l_rsa = NULL;
6323 mynam.naml$b_rss = 0;
6324 if (decc_efs_case_preserve)
6325 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6326 #ifdef NAML$M_OPEN_SPECIAL
6327 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6330 /* Set up the remaining naml fields */
6331 sts = sys$parse(&myfab);
6333 /* It failed! Try again as a UNIX filespec */
6339 /* get the Device ID and the FID */
6340 sts = sys$search(&myfab);
6341 /* on any failure, returned the POSIX ^UP^ filespec */
6346 specdsc.dsc$a_pointer = vmspath;
6347 specdsc.dsc$w_length = vmspath_len;
6349 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6350 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6351 sts = lib$fid_to_name
6352 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6354 /* on any failure, returned the POSIX ^UP^ filespec */
6356 /* This can happen if user does not have permission to read directories */
6357 if (strncmp(unixpath,"\"^UP^",5) != 0)
6358 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6360 strcpy(vmspath, unixpath);
6363 vmspath[specdsc.dsc$w_length] = 0;
6365 /* Are we expecting a directory? */
6366 if (dir_flag != 0) {
6372 i = specdsc.dsc$w_length - 1;
6376 /* Version must be '1' */
6377 if (vmspath[i--] != '1')
6379 /* Version delimiter is one of ".;" */
6380 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6383 if (vmspath[i--] != 'R')
6385 if (vmspath[i--] != 'I')
6387 if (vmspath[i--] != 'D')
6389 if (vmspath[i--] != '.')
6391 eptr = &vmspath[i+1];
6393 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6394 if (vmspath[i-1] != '^') {
6402 /* Get rid of 6 imaginary zero directory filename */
6403 vmspath[i+1] = '\0';
6407 if (vmspath[i] == '0')
6421 /* /dev/mumble needs to be handled special.
6422 /dev/null becomes NLA0:, And there is the potential for other stuff
6423 like /dev/tty which may need to be mapped to something.
6427 slash_dev_special_to_vms
6428 (const char * unixptr,
6438 nextslash = strchr(unixptr, '/');
6439 len = strlen(unixptr);
6440 if (nextslash != NULL)
6441 len = nextslash - unixptr;
6442 cmp = strncmp("null", unixptr, 5);
6444 if (vmspath_len >= 6) {
6445 strcpy(vmspath, "_NLA0:");
6452 /* The built in routines do not understand perl's special needs, so
6453 doing a manual conversion from UNIX to VMS
6455 If the utf8_fl is not null and points to a non-zero value, then
6456 treat 8 bit characters as UTF-8.
6458 The sequence starting with '$(' and ending with ')' will be passed
6459 through with out interpretation instead of being escaped.
6462 static int posix_to_vmsspec_hardway
6463 (char *vmspath, int vmspath_len,
6464 const char *unixpath,
6469 const char *unixptr;
6470 const char *unixend;
6472 const char *lastslash;
6473 const char *lastdot;
6479 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6480 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6482 if (utf8_fl != NULL)
6488 /* Ignore leading "/" characters */
6489 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6492 unixlen = strlen(unixptr);
6494 /* Do nothing with blank paths */
6501 /* This could have a "^UP^ on the front */
6502 if (strncmp(unixptr,"\"^UP^",5) == 0) {
6508 lastslash = strrchr(unixptr,'/');
6509 lastdot = strrchr(unixptr,'.');
6510 unixend = strrchr(unixptr,'\"');
6511 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6512 unixend = unixptr + unixlen;
6515 /* last dot is last dot or past end of string */
6516 if (lastdot == NULL)
6517 lastdot = unixptr + unixlen;
6519 /* if no directories, set last slash to beginning of string */
6520 if (lastslash == NULL) {
6521 lastslash = unixptr;
6524 /* Watch out for trailing "." after last slash, still a directory */
6525 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6526 lastslash = unixptr + unixlen;
6529 /* Watch out for traiing ".." after last slash, still a directory */
6530 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6531 lastslash = unixptr + unixlen;
6534 /* dots in directories are aways escaped */
6535 if (lastdot < lastslash)
6536 lastdot = unixptr + unixlen;
6539 /* if (unixptr < lastslash) then we are in a directory */
6546 /* Start with the UNIX path */
6547 if (*unixptr != '/') {
6548 /* relative paths */
6550 /* If allowing logical names on relative pathnames, then handle here */
6551 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6552 !decc_posix_compliant_pathnames) {
6558 /* Find the next slash */
6559 nextslash = strchr(unixptr,'/');
6561 esa = PerlMem_malloc(vmspath_len);
6562 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6564 trn = PerlMem_malloc(VMS_MAXRSS);
6565 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6567 if (nextslash != NULL) {
6569 seg_len = nextslash - unixptr;
6570 strncpy(esa, unixptr, seg_len);
6574 strcpy(esa, unixptr);
6575 seg_len = strlen(unixptr);
6577 /* trnlnm(section) */
6578 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6581 /* Now fix up the directory */
6583 /* Split up the path to find the components */
6584 sts = vms_split_path
6603 /* A logical name must be a directory or the full
6604 specification. It is only a full specification if
6605 it is the only component */
6606 if ((unixptr[seg_len] == '\0') ||
6607 (unixptr[seg_len+1] == '\0')) {
6609 /* Is a directory being required? */
6610 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6611 /* Not a logical name */
6616 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6617 /* This must be a directory */
6618 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6619 strcpy(vmsptr, esa);
6620 vmslen=strlen(vmsptr);
6621 vmsptr[vmslen] = ':';
6623 vmsptr[vmslen] = '\0';
6631 /* must be dev/directory - ignore version */
6632 if ((n_len + e_len) != 0)
6635 /* transfer the volume */
6636 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6637 strncpy(vmsptr, v_spec, v_len);
6643 /* unroot the rooted directory */
6644 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6646 r_spec[r_len - 1] = ']';
6648 /* This should not be there, but nothing is perfect */
6650 cmp = strcmp(&r_spec[1], "000000.");
6660 strncpy(vmsptr, r_spec, r_len);
6666 /* Bring over the directory. */
6668 ((d_len + vmslen) < vmspath_len)) {
6670 d_spec[d_len - 1] = ']';
6672 cmp = strcmp(&d_spec[1], "000000.");
6683 /* Remove the redundant root */
6691 strncpy(vmsptr, d_spec, d_len);
6705 if (lastslash > unixptr) {
6708 /* skip leading ./ */
6710 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6716 /* Are we still in a directory? */
6717 if (unixptr <= lastslash) {
6722 /* if not backing up, then it is relative forward. */
6723 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6724 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6732 /* Perl wants an empty directory here to tell the difference
6733 * between a DCL commmand and a filename
6742 /* Handle two special files . and .. */
6743 if (unixptr[0] == '.') {
6744 if (&unixptr[1] == unixend) {
6751 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6762 else { /* Absolute PATH handling */
6766 /* Need to find out where root is */
6768 /* In theory, this procedure should never get an absolute POSIX pathname
6769 * that can not be found on the POSIX root.
6770 * In practice, that can not be relied on, and things will show up
6771 * here that are a VMS device name or concealed logical name instead.
6772 * So to make things work, this procedure must be tolerant.
6774 esa = PerlMem_malloc(vmspath_len);
6775 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6778 nextslash = strchr(&unixptr[1],'/');
6780 if (nextslash != NULL) {
6782 seg_len = nextslash - &unixptr[1];
6783 strncpy(vmspath, unixptr, seg_len + 1);
6784 vmspath[seg_len+1] = 0;
6787 cmp = strncmp(vmspath, "dev", 4);
6789 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6790 if (sts = SS$_NORMAL)
6794 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6797 if ($VMS_STATUS_SUCCESS(sts)) {
6798 /* This is verified to be a real path */
6800 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6801 if ($VMS_STATUS_SUCCESS(sts)) {
6802 strcpy(vmspath, esa);
6803 vmslen = strlen(vmspath);
6804 vmsptr = vmspath + vmslen;
6806 if (unixptr < lastslash) {
6815 cmp = strcmp(rptr,"000000.");
6820 } /* removing 6 zeros */
6821 } /* vmslen < 7, no 6 zeros possible */
6822 } /* Not in a directory */
6823 } /* Posix root found */
6825 /* No posix root, fall back to default directory */
6826 strcpy(vmspath, "SYS$DISK:[");
6827 vmsptr = &vmspath[10];
6829 if (unixptr > lastslash) {
6838 } /* end of verified real path handling */
6843 /* Ok, we have a device or a concealed root that is not in POSIX
6844 * or we have garbage. Make the best of it.
6847 /* Posix to VMS destroyed this, so copy it again */
6848 strncpy(vmspath, &unixptr[1], seg_len);
6849 vmspath[seg_len] = 0;
6851 vmsptr = &vmsptr[vmslen];
6854 /* Now do we need to add the fake 6 zero directory to it? */
6856 if ((*lastslash == '/') && (nextslash < lastslash)) {
6857 /* No there is another directory */
6864 /* now we have foo:bar or foo:[000000]bar to decide from */
6865 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6867 if (!islnm && !decc_posix_compliant_pathnames) {
6869 cmp = strncmp("bin", vmspath, 4);
6871 /* bin => SYS$SYSTEM: */
6872 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6875 /* tmp => SYS$SCRATCH: */
6876 cmp = strncmp("tmp", vmspath, 4);
6878 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6883 trnend = islnm ? islnm - 1 : 0;
6885 /* if this was a logical name, ']' or '>' must be present */
6886 /* if not a logical name, then assume a device and hope. */
6887 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6889 /* if log name and trailing '.' then rooted - treat as device */
6890 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6892 /* Fix me, if not a logical name, a device lookup should be
6893 * done to see if the device is file structured. If the device
6894 * is not file structured, the 6 zeros should not be put on.
6896 * As it is, perl is occasionally looking for dev:[000000]tty.
6897 * which looks a little strange.
6899 * Not that easy to detect as "/dev" may be file structured with
6900 * special device files.
6903 if ((add_6zero == 0) && (*nextslash == '/') &&
6904 (&nextslash[1] == unixend)) {
6905 /* No real directory present */
6910 /* Put the device delimiter on */
6913 unixptr = nextslash;
6916 /* Start directory if needed */
6917 if (!islnm || add_6zero) {
6923 /* add fake 000000] if needed */
6936 } /* non-POSIX translation */
6938 } /* End of relative/absolute path handling */
6940 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6947 if (dir_start != 0) {
6949 /* First characters in a directory are handled special */
6950 while ((*unixptr == '/') ||
6951 ((*unixptr == '.') &&
6952 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6953 (&unixptr[1]==unixend)))) {
6958 /* Skip redundant / in specification */
6959 while ((*unixptr == '/') && (dir_start != 0)) {
6962 if (unixptr == lastslash)
6965 if (unixptr == lastslash)
6968 /* Skip redundant ./ characters */
6969 while ((*unixptr == '.') &&
6970 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6973 if (unixptr == lastslash)
6975 if (*unixptr == '/')
6978 if (unixptr == lastslash)
6981 /* Skip redundant ../ characters */
6982 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6983 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6984 /* Set the backing up flag */
6990 unixptr++; /* first . */
6991 unixptr++; /* second . */
6992 if (unixptr == lastslash)
6994 if (*unixptr == '/') /* The slash */
6997 if (unixptr == lastslash)
7000 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7001 /* Not needed when VMS is pretending to be UNIX. */
7003 /* Is this loop stuck because of too many dots? */
7004 if (loop_flag == 0) {
7005 /* Exit the loop and pass the rest through */
7010 /* Are we done with directories yet? */
7011 if (unixptr >= lastslash) {
7013 /* Watch out for trailing dots */
7022 if (*unixptr == '/')
7026 /* Have we stopped backing up? */
7031 /* dir_start continues to be = 1 */
7033 if (*unixptr == '-') {
7035 *vmsptr++ = *unixptr++;
7039 /* Now are we done with directories yet? */
7040 if (unixptr >= lastslash) {
7042 /* Watch out for trailing dots */
7058 if (unixptr >= unixend)
7061 /* Normal characters - More EFS work probably needed */
7067 /* remove multiple / */
7068 while (unixptr[1] == '/') {
7071 if (unixptr == lastslash) {
7072 /* Watch out for trailing dots */
7084 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7085 /* Not needed when VMS is pretending to be UNIX. */
7089 if (unixptr != unixend)
7094 if ((unixptr < lastdot) || (unixptr < lastslash) ||
7095 (&unixptr[1] == unixend)) {
7101 /* trailing dot ==> '^..' on VMS */
7102 if (unixptr == unixend) {
7110 *vmsptr++ = *unixptr++;
7114 if (quoted && (&unixptr[1] == unixend)) {
7118 in_cnt = copy_expand_unix_filename_escape
7119 (vmsptr, unixptr, &out_cnt, utf8_fl);
7129 in_cnt = copy_expand_unix_filename_escape
7130 (vmsptr, unixptr, &out_cnt, utf8_fl);
7137 /* Make sure directory is closed */
7138 if (unixptr == lastslash) {
7140 vmsptr2 = vmsptr - 1;
7142 if (*vmsptr2 != ']') {
7145 /* directories do not end in a dot bracket */
7146 if (*vmsptr2 == '.') {
7150 if (*vmsptr2 != '^') {
7151 vmsptr--; /* back up over the dot */
7159 /* Add a trailing dot if a file with no extension */
7160 vmsptr2 = vmsptr - 1;
7162 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7163 (*vmsptr2 != ')') && (*lastdot != '.')) {
7174 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7175 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7180 /* If a UTF8 flag is being passed, honor it */
7182 if (utf8_fl != NULL) {
7183 utf8_flag = *utf8_fl;
7188 /* If there is a possibility of UTF8, then if any UTF8 characters
7189 are present, then they must be converted to VTF-7
7191 result = strcpy(rslt, path); /* FIX-ME */
7194 result = strcpy(rslt, path);
7200 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7201 static char *mp_do_tovmsspec
7202 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7203 static char __tovmsspec_retbuf[VMS_MAXRSS];
7204 char *rslt, *dirend;
7209 unsigned long int infront = 0, hasdir = 1;
7212 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7213 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7215 if (path == NULL) return NULL;
7216 rslt_len = VMS_MAXRSS-1;
7217 if (buf) rslt = buf;
7218 else if (ts) Newx(rslt, VMS_MAXRSS, char);
7219 else rslt = __tovmsspec_retbuf;
7221 /* '.' and '..' are "[]" and "[-]" for a quick check */
7222 if (path[0] == '.') {
7223 if (path[1] == '\0') {
7225 if (utf8_flag != NULL)
7230 if (path[1] == '.' && path[2] == '\0') {
7232 if (utf8_flag != NULL)
7239 /* Posix specifications are now a native VMS format */
7240 /*--------------------------------------------------*/
7241 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7242 if (decc_posix_compliant_pathnames) {
7243 if (strncmp(path,"\"^UP^",5) == 0) {
7244 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7250 /* This is really the only way to see if this is already in VMS format */
7251 sts = vms_split_path
7266 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7267 replacement, because the above parse just took care of most of
7268 what is needed to do vmspath when the specification is already
7271 And if it is not already, it is easier to do the conversion as
7272 part of this routine than to call this routine and then work on
7276 /* If VMS punctuation was found, it is already VMS format */
7277 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7278 if (utf8_flag != NULL)
7283 /* Now, what to do with trailing "." cases where there is no
7284 extension? If this is a UNIX specification, and EFS characters
7285 are enabled, then the trailing "." should be converted to a "^.".
7286 But if this was already a VMS specification, then it should be
7289 So in the case of ambiguity, leave the specification alone.
7293 /* If there is a possibility of UTF8, then if any UTF8 characters
7294 are present, then they must be converted to VTF-7
7296 if (utf8_flag != NULL)
7302 dirend = strrchr(path,'/');
7304 if (dirend == NULL) {
7305 /* If we get here with no UNIX directory delimiters, then this is
7306 not a complete file specification, either garbage a UNIX glob
7307 specification that can not be converted to a VMS wildcard, or
7308 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7309 so apparently other programs expect this also.
7311 utf8 flag setting needs to be preserved.
7317 /* If POSIX mode active, handle the conversion */
7318 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7319 if (decc_efs_charset) {
7320 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7325 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
7326 if (!*(dirend+2)) dirend +=2;
7327 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7328 if (decc_efs_charset == 0) {
7329 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7335 lastdot = strrchr(cp2,'.');
7341 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7343 if (decc_disable_posix_root) {
7344 strcpy(rslt,"sys$disk:[000000]");
7347 strcpy(rslt,"sys$posix_root:[000000]");
7349 if (utf8_flag != NULL)
7353 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7355 trndev = PerlMem_malloc(VMS_MAXRSS);
7356 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7357 islnm = my_trnlnm(rslt,trndev,0);
7359 /* DECC special handling */
7361 if (strcmp(rslt,"bin") == 0) {
7362 strcpy(rslt,"sys$system");
7365 islnm = my_trnlnm(rslt,trndev,0);
7367 else if (strcmp(rslt,"tmp") == 0) {
7368 strcpy(rslt,"sys$scratch");
7371 islnm = my_trnlnm(rslt,trndev,0);
7373 else if (!decc_disable_posix_root) {
7374 strcpy(rslt, "sys$posix_root");
7378 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7379 islnm = my_trnlnm(rslt,trndev,0);
7381 else if (strcmp(rslt,"dev") == 0) {
7382 if (strncmp(cp2,"/null", 5) == 0) {
7383 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7384 strcpy(rslt,"NLA0");
7388 islnm = my_trnlnm(rslt,trndev,0);
7394 trnend = islnm ? strlen(trndev) - 1 : 0;
7395 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7396 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7397 /* If the first element of the path is a logical name, determine
7398 * whether it has to be translated so we can add more directories. */
7399 if (!islnm || rooted) {
7402 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7406 if (cp2 != dirend) {
7407 strcpy(rslt,trndev);
7408 cp1 = rslt + trnend;
7415 if (decc_disable_posix_root) {
7421 PerlMem_free(trndev);
7426 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7427 cp2 += 2; /* skip over "./" - it's redundant */
7428 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
7430 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7431 *(cp1++) = '-'; /* "../" --> "-" */
7434 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7435 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7436 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7437 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7440 else if ((cp2 != lastdot) || (lastdot < dirend)) {
7441 /* Escape the extra dots in EFS file specifications */
7444 if (cp2 > dirend) cp2 = dirend;
7446 else *(cp1++) = '.';
7448 for (; cp2 < dirend; cp2++) {
7450 if (*(cp2-1) == '/') continue;
7451 if (*(cp1-1) != '.') *(cp1++) = '.';
7454 else if (!infront && *cp2 == '.') {
7455 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7456 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
7457 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7458 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7459 else if (*(cp1-2) == '[') *(cp1-1) = '-';
7460 else { /* back up over previous directory name */
7462 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7463 if (*(cp1-1) == '[') {
7464 memcpy(cp1,"000000.",7);
7469 if (cp2 == dirend) break;
7471 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7472 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7473 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7474 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7476 *(cp1++) = '.'; /* Simulate trailing '/' */
7477 cp2 += 2; /* for loop will incr this to == dirend */
7479 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
7482 if (decc_efs_charset == 0)
7483 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
7485 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
7491 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
7493 if (decc_efs_charset == 0)
7500 else *(cp1++) = *cp2;
7504 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7505 if (hasdir) *(cp1++) = ']';
7506 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
7507 /* fixme for ODS5 */
7514 if (decc_efs_charset == 0)
7525 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7526 decc_readdir_dropdotnotype) {
7531 /* trailing dot ==> '^..' on VMS */
7538 *(cp1++) = *(cp2++);
7543 /* This could be a macro to be passed through */
7544 *(cp1++) = *(cp2++);
7546 const char * save_cp2;
7550 /* paranoid check */
7556 *(cp1++) = *(cp2++);
7557 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7558 *(cp1++) = *(cp2++);
7559 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7560 *(cp1++) = *(cp2++);
7563 *(cp1++) = *(cp2++);
7567 if (is_macro == 0) {
7568 /* Not really a macro - never mind */
7581 /* Don't escape again if following character is
7582 * already something we escape.
7584 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
7585 *(cp1++) = *(cp2++);
7588 /* But otherwise fall through and escape it. */
7606 *(cp1++) = *(cp2++);
7609 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7610 * which is wrong. UNIX notation should be ".dir." unless
7611 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7612 * changing this behavior could break more things at this time.
7613 * efs character set effectively does not allow "." to be a version
7614 * delimiter as a further complication about changing this.
7616 if (decc_filename_unix_report != 0) {
7619 *(cp1++) = *(cp2++);
7622 *(cp1++) = *(cp2++);
7625 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7629 /* Fix me for "^]", but that requires making sure that you do
7630 * not back up past the start of the filename
7632 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7637 if (utf8_flag != NULL)
7641 } /* end of do_tovmsspec() */
7643 /* External entry points */
7644 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7645 { return do_tovmsspec(path,buf,0,NULL); }
7646 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7647 { return do_tovmsspec(path,buf,1,NULL); }
7648 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7649 { return do_tovmsspec(path,buf,0,utf8_fl); }
7650 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7651 { return do_tovmsspec(path,buf,1,utf8_fl); }
7653 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7654 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7655 static char __tovmspath_retbuf[VMS_MAXRSS];
7657 char *pathified, *vmsified, *cp;
7659 if (path == NULL) return NULL;
7660 pathified = PerlMem_malloc(VMS_MAXRSS);
7661 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7662 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7663 PerlMem_free(pathified);
7669 Newx(vmsified, VMS_MAXRSS, char);
7670 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7671 PerlMem_free(pathified);
7672 if (vmsified) Safefree(vmsified);
7675 PerlMem_free(pathified);
7680 vmslen = strlen(vmsified);
7681 Newx(cp,vmslen+1,char);
7682 memcpy(cp,vmsified,vmslen);
7688 strcpy(__tovmspath_retbuf,vmsified);
7690 return __tovmspath_retbuf;
7693 } /* end of do_tovmspath() */
7695 /* External entry points */
7696 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7697 { return do_tovmspath(path,buf,0, NULL); }
7698 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7699 { return do_tovmspath(path,buf,1, NULL); }
7700 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7701 { return do_tovmspath(path,buf,0,utf8_fl); }
7702 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7703 { return do_tovmspath(path,buf,1,utf8_fl); }
7706 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7707 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7708 static char __tounixpath_retbuf[VMS_MAXRSS];
7710 char *pathified, *unixified, *cp;
7712 if (path == NULL) return NULL;
7713 pathified = PerlMem_malloc(VMS_MAXRSS);
7714 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7715 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7716 PerlMem_free(pathified);
7722 Newx(unixified, VMS_MAXRSS, char);
7724 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7725 PerlMem_free(pathified);
7726 if (unixified) Safefree(unixified);
7729 PerlMem_free(pathified);
7734 unixlen = strlen(unixified);
7735 Newx(cp,unixlen+1,char);
7736 memcpy(cp,unixified,unixlen);
7738 Safefree(unixified);
7742 strcpy(__tounixpath_retbuf,unixified);
7743 Safefree(unixified);
7744 return __tounixpath_retbuf;
7747 } /* end of do_tounixpath() */
7749 /* External entry points */
7750 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7751 { return do_tounixpath(path,buf,0,NULL); }
7752 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7753 { return do_tounixpath(path,buf,1,NULL); }
7754 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7755 { return do_tounixpath(path,buf,0,utf8_fl); }
7756 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7757 { return do_tounixpath(path,buf,1,utf8_fl); }
7760 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
7762 *****************************************************************************
7764 * Copyright (C) 1989-1994, 2007 by *
7765 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
7767 * Permission is hereby granted for the reproduction of this software *
7768 * on condition that this copyright notice is included in source *
7769 * distributions of the software. The code may be modified and *
7770 * distributed under the same terms as Perl itself. *
7772 * 27-Aug-1994 Modified for inclusion in perl5 *
7773 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
7774 *****************************************************************************
7778 * getredirection() is intended to aid in porting C programs
7779 * to VMS (Vax-11 C). The native VMS environment does not support
7780 * '>' and '<' I/O redirection, or command line wild card expansion,
7781 * or a command line pipe mechanism using the '|' AND background
7782 * command execution '&'. All of these capabilities are provided to any
7783 * C program which calls this procedure as the first thing in the
7785 * The piping mechanism will probably work with almost any 'filter' type
7786 * of program. With suitable modification, it may useful for other
7787 * portability problems as well.
7789 * Author: Mark Pizzolato (mark AT infocomm DOT com)
7793 struct list_item *next;
7797 static void add_item(struct list_item **head,
7798 struct list_item **tail,
7802 static void mp_expand_wild_cards(pTHX_ char *item,
7803 struct list_item **head,
7804 struct list_item **tail,
7807 static int background_process(pTHX_ int argc, char **argv);
7809 static void pipe_and_fork(pTHX_ char **cmargv);
7811 /*{{{ void getredirection(int *ac, char ***av)*/
7813 mp_getredirection(pTHX_ int *ac, char ***av)
7815 * Process vms redirection arg's. Exit if any error is seen.
7816 * If getredirection() processes an argument, it is erased
7817 * from the vector. getredirection() returns a new argc and argv value.
7818 * In the event that a background command is requested (by a trailing "&"),
7819 * this routine creates a background subprocess, and simply exits the program.
7821 * Warning: do not try to simplify the code for vms. The code
7822 * presupposes that getredirection() is called before any data is
7823 * read from stdin or written to stdout.
7825 * Normal usage is as follows:
7831 * getredirection(&argc, &argv);
7835 int argc = *ac; /* Argument Count */
7836 char **argv = *av; /* Argument Vector */
7837 char *ap; /* Argument pointer */
7838 int j; /* argv[] index */
7839 int item_count = 0; /* Count of Items in List */
7840 struct list_item *list_head = 0; /* First Item in List */
7841 struct list_item *list_tail; /* Last Item in List */
7842 char *in = NULL; /* Input File Name */
7843 char *out = NULL; /* Output File Name */
7844 char *outmode = "w"; /* Mode to Open Output File */
7845 char *err = NULL; /* Error File Name */
7846 char *errmode = "w"; /* Mode to Open Error File */
7847 int cmargc = 0; /* Piped Command Arg Count */
7848 char **cmargv = NULL;/* Piped Command Arg Vector */
7851 * First handle the case where the last thing on the line ends with
7852 * a '&'. This indicates the desire for the command to be run in a
7853 * subprocess, so we satisfy that desire.
7856 if (0 == strcmp("&", ap))
7857 exit(background_process(aTHX_ --argc, argv));
7858 if (*ap && '&' == ap[strlen(ap)-1])
7860 ap[strlen(ap)-1] = '\0';
7861 exit(background_process(aTHX_ argc, argv));
7864 * Now we handle the general redirection cases that involve '>', '>>',
7865 * '<', and pipes '|'.
7867 for (j = 0; j < argc; ++j)
7869 if (0 == strcmp("<", argv[j]))
7873 fprintf(stderr,"No input file after < on command line");
7874 exit(LIB$_WRONUMARG);
7879 if ('<' == *(ap = argv[j]))
7884 if (0 == strcmp(">", ap))
7888 fprintf(stderr,"No output file after > on command line");
7889 exit(LIB$_WRONUMARG);
7908 fprintf(stderr,"No output file after > or >> on command line");
7909 exit(LIB$_WRONUMARG);
7913 if (('2' == *ap) && ('>' == ap[1]))
7930 fprintf(stderr,"No output file after 2> or 2>> on command line");
7931 exit(LIB$_WRONUMARG);
7935 if (0 == strcmp("|", argv[j]))
7939 fprintf(stderr,"No command into which to pipe on command line");
7940 exit(LIB$_WRONUMARG);
7942 cmargc = argc-(j+1);
7943 cmargv = &argv[j+1];
7947 if ('|' == *(ap = argv[j]))
7955 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7958 * Allocate and fill in the new argument vector, Some Unix's terminate
7959 * the list with an extra null pointer.
7961 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7962 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7964 for (j = 0; j < item_count; ++j, list_head = list_head->next)
7965 argv[j] = list_head->value;
7971 fprintf(stderr,"'|' and '>' may not both be specified on command line");
7972 exit(LIB$_INVARGORD);
7974 pipe_and_fork(aTHX_ cmargv);
7977 /* Check for input from a pipe (mailbox) */
7979 if (in == NULL && 1 == isapipe(0))
7981 char mbxname[L_tmpnam];
7983 long int dvi_item = DVI$_DEVBUFSIZ;
7984 $DESCRIPTOR(mbxnam, "");
7985 $DESCRIPTOR(mbxdevnam, "");
7987 /* Input from a pipe, reopen it in binary mode to disable */
7988 /* carriage control processing. */
7990 fgetname(stdin, mbxname);
7991 mbxnam.dsc$a_pointer = mbxname;
7992 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7993 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7994 mbxdevnam.dsc$a_pointer = mbxname;
7995 mbxdevnam.dsc$w_length = sizeof(mbxname);
7996 dvi_item = DVI$_DEVNAM;
7997 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7998 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8001 freopen(mbxname, "rb", stdin);
8004 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8008 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8010 fprintf(stderr,"Can't open input file %s as stdin",in);
8013 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8015 fprintf(stderr,"Can't open output file %s as stdout",out);
8018 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8021 if (strcmp(err,"&1") == 0) {
8022 dup2(fileno(stdout), fileno(stderr));
8023 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8026 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8028 fprintf(stderr,"Can't open error file %s as stderr",err);
8032 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8036 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8039 #ifdef ARGPROC_DEBUG
8040 PerlIO_printf(Perl_debug_log, "Arglist:\n");
8041 for (j = 0; j < *ac; ++j)
8042 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8044 /* Clear errors we may have hit expanding wildcards, so they don't
8045 show up in Perl's $! later */
8046 set_errno(0); set_vaxc_errno(1);
8047 } /* end of getredirection() */
8050 static void add_item(struct list_item **head,
8051 struct list_item **tail,
8057 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8058 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8062 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8063 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8064 *tail = (*tail)->next;
8066 (*tail)->value = value;
8070 static void mp_expand_wild_cards(pTHX_ char *item,
8071 struct list_item **head,
8072 struct list_item **tail,
8076 unsigned long int context = 0;
8084 $DESCRIPTOR(filespec, "");
8085 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8086 $DESCRIPTOR(resultspec, "");
8087 unsigned long int lff_flags = 0;
8091 #ifdef VMS_LONGNAME_SUPPORT
8092 lff_flags = LIB$M_FIL_LONG_NAMES;
8095 for (cp = item; *cp; cp++) {
8096 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8097 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8099 if (!*cp || isspace(*cp))
8101 add_item(head, tail, item, count);
8106 /* "double quoted" wild card expressions pass as is */
8107 /* From DCL that means using e.g.: */
8108 /* perl program """perl.*""" */
8109 item_len = strlen(item);
8110 if ( '"' == *item && '"' == item[item_len-1] )
8113 item[item_len-2] = '\0';
8114 add_item(head, tail, item, count);
8118 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8119 resultspec.dsc$b_class = DSC$K_CLASS_D;
8120 resultspec.dsc$a_pointer = NULL;
8121 vmsspec = PerlMem_malloc(VMS_MAXRSS);
8122 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8123 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8124 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8125 if (!isunix || !filespec.dsc$a_pointer)
8126 filespec.dsc$a_pointer = item;
8127 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8129 * Only return version specs, if the caller specified a version
8131 had_version = strchr(item, ';');
8133 * Only return device and directory specs, if the caller specifed either.
8135 had_device = strchr(item, ':');
8136 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8138 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8139 (&filespec, &resultspec, &context,
8140 &defaultspec, 0, &rms_sts, &lff_flags)))
8145 string = PerlMem_malloc(resultspec.dsc$w_length+1);
8146 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8147 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8148 string[resultspec.dsc$w_length] = '\0';
8149 if (NULL == had_version)
8150 *(strrchr(string, ';')) = '\0';
8151 if ((!had_directory) && (had_device == NULL))
8153 if (NULL == (devdir = strrchr(string, ']')))
8154 devdir = strrchr(string, '>');
8155 strcpy(string, devdir + 1);
8158 * Be consistent with what the C RTL has already done to the rest of
8159 * the argv items and lowercase all of these names.
8161 if (!decc_efs_case_preserve) {
8162 for (c = string; *c; ++c)
8166 if (isunix) trim_unixpath(string,item,1);
8167 add_item(head, tail, string, count);
8170 PerlMem_free(vmsspec);
8171 if (sts != RMS$_NMF)
8173 set_vaxc_errno(sts);
8176 case RMS$_FNF: case RMS$_DNF:
8177 set_errno(ENOENT); break;
8179 set_errno(ENOTDIR); break;
8181 set_errno(ENODEV); break;
8182 case RMS$_FNM: case RMS$_SYN:
8183 set_errno(EINVAL); break;
8185 set_errno(EACCES); break;
8187 _ckvmssts_noperl(sts);
8191 add_item(head, tail, item, count);
8192 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8193 _ckvmssts_noperl(lib$find_file_end(&context));
8196 static int child_st[2];/* Event Flag set when child process completes */
8198 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
8200 static unsigned long int exit_handler(int *status)
8204 if (0 == child_st[0])
8206 #ifdef ARGPROC_DEBUG
8207 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8209 fflush(stdout); /* Have to flush pipe for binary data to */
8210 /* terminate properly -- <tp@mccall.com> */
8211 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8212 sys$dassgn(child_chan);
8214 sys$synch(0, child_st);
8219 static void sig_child(int chan)
8221 #ifdef ARGPROC_DEBUG
8222 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8224 if (child_st[0] == 0)
8228 static struct exit_control_block exit_block =
8233 &exit_block.exit_status,
8238 pipe_and_fork(pTHX_ char **cmargv)
8241 struct dsc$descriptor_s *vmscmd;
8242 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8243 int sts, j, l, ismcr, quote, tquote = 0;
8245 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
8246 vms_execfree(vmscmd);
8251 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
8252 && toupper(*(q+2)) == 'R' && !*(q+3);
8254 while (q && l < MAX_DCL_LINE_LENGTH) {
8256 if (j > 0 && quote) {
8262 if (ismcr && j > 1) quote = 1;
8263 tquote = (strchr(q,' ')) != NULL || *q == '\0';
8266 if (quote || tquote) {
8272 if ((quote||tquote) && *q == '"') {
8282 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8284 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8288 static int background_process(pTHX_ int argc, char **argv)
8290 char command[MAX_DCL_SYMBOL + 1] = "$";
8291 $DESCRIPTOR(value, "");
8292 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8293 static $DESCRIPTOR(null, "NLA0:");
8294 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8296 $DESCRIPTOR(pidstr, "");
8298 unsigned long int flags = 17, one = 1, retsts;
8301 strcat(command, argv[0]);
8302 len = strlen(command);
8303 while (--argc && (len < MAX_DCL_SYMBOL))
8305 strcat(command, " \"");
8306 strcat(command, *(++argv));
8307 strcat(command, "\"");
8308 len = strlen(command);
8310 value.dsc$a_pointer = command;
8311 value.dsc$w_length = strlen(value.dsc$a_pointer);
8312 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8313 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8314 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8315 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8318 _ckvmssts_noperl(retsts);
8320 #ifdef ARGPROC_DEBUG
8321 PerlIO_printf(Perl_debug_log, "%s\n", command);
8323 sprintf(pidstring, "%08X", pid);
8324 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8325 pidstr.dsc$a_pointer = pidstring;
8326 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8327 lib$set_symbol(&pidsymbol, &pidstr);
8331 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8334 /* OS-specific initialization at image activation (not thread startup) */
8335 /* Older VAXC header files lack these constants */
8336 #ifndef JPI$_RIGHTS_SIZE
8337 # define JPI$_RIGHTS_SIZE 817
8339 #ifndef KGB$M_SUBSYSTEM
8340 # define KGB$M_SUBSYSTEM 0x8
8343 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8345 /*{{{void vms_image_init(int *, char ***)*/
8347 vms_image_init(int *argcp, char ***argvp)
8349 char eqv[LNM$C_NAMLENGTH+1] = "";
8350 unsigned int len, tabct = 8, tabidx = 0;
8351 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8352 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8353 unsigned short int dummy, rlen;
8354 struct dsc$descriptor_s **tabvec;
8355 #if defined(PERL_IMPLICIT_CONTEXT)
8358 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8359 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8360 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8363 #ifdef KILL_BY_SIGPRC
8364 Perl_csighandler_init();
8367 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8368 _ckvmssts_noperl(iosb[0]);
8369 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8370 if (iprv[i]) { /* Running image installed with privs? */
8371 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
8376 /* Rights identifiers might trigger tainting as well. */
8377 if (!will_taint && (rlen || rsz)) {
8378 while (rlen < rsz) {
8379 /* We didn't get all the identifiers on the first pass. Allocate a
8380 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8381 * were needed to hold all identifiers at time of last call; we'll
8382 * allocate that many unsigned long ints), and go back and get 'em.
8383 * If it gave us less than it wanted to despite ample buffer space,
8384 * something's broken. Is your system missing a system identifier?
8386 if (rsz <= jpilist[1].buflen) {
8387 /* Perl_croak accvios when used this early in startup. */
8388 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8389 rsz, (unsigned long) jpilist[1].buflen,
8390 "Check your rights database for corruption.\n");
8393 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8394 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8395 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8396 jpilist[1].buflen = rsz * sizeof(unsigned long int);
8397 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8398 _ckvmssts_noperl(iosb[0]);
8400 mask = jpilist[1].bufadr;
8401 /* Check attribute flags for each identifier (2nd longword); protected
8402 * subsystem identifiers trigger tainting.
8404 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8405 if (mask[i] & KGB$M_SUBSYSTEM) {
8410 if (mask != rlst) PerlMem_free(mask);
8413 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8414 * logical, some versions of the CRTL will add a phanthom /000000/
8415 * directory. This needs to be removed.
8417 if (decc_filename_unix_report) {
8420 ulen = strlen(argvp[0][0]);
8422 zeros = strstr(argvp[0][0], "/000000/");
8423 if (zeros != NULL) {
8425 mlen = ulen - (zeros - argvp[0][0]) - 7;
8426 memmove(zeros, &zeros[7], mlen);
8428 argvp[0][0][ulen] = '\0';
8431 /* It also may have a trailing dot that needs to be removed otherwise
8432 * it will be converted to VMS mode incorrectly.
8435 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8436 argvp[0][0][ulen] = '\0';
8439 /* We need to use this hack to tell Perl it should run with tainting,
8440 * since its tainting flag may be part of the PL_curinterp struct, which
8441 * hasn't been allocated when vms_image_init() is called.
8444 char **newargv, **oldargv;
8446 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8447 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8448 newargv[0] = oldargv[0];
8449 newargv[1] = PerlMem_malloc(3 * sizeof(char));
8450 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8451 strcpy(newargv[1], "-T");
8452 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8454 newargv[*argcp] = NULL;
8455 /* We orphan the old argv, since we don't know where it's come from,
8456 * so we don't know how to free it.
8460 else { /* Did user explicitly request tainting? */
8462 char *cp, **av = *argvp;
8463 for (i = 1; i < *argcp; i++) {
8464 if (*av[i] != '-') break;
8465 for (cp = av[i]+1; *cp; cp++) {
8466 if (*cp == 'T') { will_taint = 1; break; }
8467 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8468 strchr("DFIiMmx",*cp)) break;
8470 if (will_taint) break;
8475 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8478 tabvec = (struct dsc$descriptor_s **)
8479 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8480 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8482 else if (tabidx >= tabct) {
8484 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8485 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8487 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8488 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8489 tabvec[tabidx]->dsc$w_length = 0;
8490 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
8491 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
8492 tabvec[tabidx]->dsc$a_pointer = NULL;
8493 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8495 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8497 getredirection(argcp,argvp);
8498 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8500 # include <reentrancy.h>
8501 decc$set_reentrancy(C$C_MULTITHREAD);
8510 * Trim Unix-style prefix off filespec, so it looks like what a shell
8511 * glob expansion would return (i.e. from specified prefix on, not
8512 * full path). Note that returned filespec is Unix-style, regardless
8513 * of whether input filespec was VMS-style or Unix-style.
8515 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8516 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
8517 * vector of options; at present, only bit 0 is used, and if set tells
8518 * trim unixpath to try the current default directory as a prefix when
8519 * presented with a possibly ambiguous ... wildcard.
8521 * Returns !=0 on success, with trimmed filespec replacing contents of
8522 * fspec, and 0 on failure, with contents of fpsec unchanged.
8524 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8526 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8528 char *unixified, *unixwild,
8529 *template, *base, *end, *cp1, *cp2;
8530 register int tmplen, reslen = 0, dirs = 0;
8532 unixwild = PerlMem_malloc(VMS_MAXRSS);
8533 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8534 if (!wildspec || !fspec) return 0;
8535 template = unixwild;
8536 if (strpbrk(wildspec,"]>:") != NULL) {
8537 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8538 PerlMem_free(unixwild);
8543 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8544 unixwild[VMS_MAXRSS-1] = 0;
8546 unixified = PerlMem_malloc(VMS_MAXRSS);
8547 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8548 if (strpbrk(fspec,"]>:") != NULL) {
8549 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8550 PerlMem_free(unixwild);
8551 PerlMem_free(unixified);
8554 else base = unixified;
8555 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8556 * check to see that final result fits into (isn't longer than) fspec */
8557 reslen = strlen(fspec);
8561 /* No prefix or absolute path on wildcard, so nothing to remove */
8562 if (!*template || *template == '/') {
8563 PerlMem_free(unixwild);
8564 if (base == fspec) {
8565 PerlMem_free(unixified);
8568 tmplen = strlen(unixified);
8569 if (tmplen > reslen) {
8570 PerlMem_free(unixified);
8571 return 0; /* not enough space */
8573 /* Copy unixified resultant, including trailing NUL */
8574 memmove(fspec,unixified,tmplen+1);
8575 PerlMem_free(unixified);
8579 for (end = base; *end; end++) ; /* Find end of resultant filespec */
8580 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8581 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8582 for (cp1 = end ;cp1 >= base; cp1--)
8583 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8585 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8586 PerlMem_free(unixified);
8587 PerlMem_free(unixwild);
8592 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8593 int ells = 1, totells, segdirs, match;
8594 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8595 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8597 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8599 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8600 tpl = PerlMem_malloc(VMS_MAXRSS);
8601 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8602 if (ellipsis == template && opts & 1) {
8603 /* Template begins with an ellipsis. Since we can't tell how many
8604 * directory names at the front of the resultant to keep for an
8605 * arbitrary starting point, we arbitrarily choose the current
8606 * default directory as a starting point. If it's there as a prefix,
8607 * clip it off. If not, fall through and act as if the leading
8608 * ellipsis weren't there (i.e. return shortest possible path that
8609 * could match template).
8611 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8613 PerlMem_free(unixified);
8614 PerlMem_free(unixwild);
8617 if (!decc_efs_case_preserve) {
8618 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8619 if (_tolower(*cp1) != _tolower(*cp2)) break;
8621 segdirs = dirs - totells; /* Min # of dirs we must have left */
8622 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8623 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8624 memmove(fspec,cp2+1,end - cp2);
8626 PerlMem_free(unixified);
8627 PerlMem_free(unixwild);
8631 /* First off, back up over constant elements at end of path */
8633 for (front = end ; front >= base; front--)
8634 if (*front == '/' && !dirs--) { front++; break; }
8636 lcres = PerlMem_malloc(VMS_MAXRSS);
8637 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8638 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8640 if (!decc_efs_case_preserve) {
8641 *cp2 = _tolower(*cp1); /* Make lc copy for match */
8649 PerlMem_free(unixified);
8650 PerlMem_free(unixwild);
8651 PerlMem_free(lcres);
8652 return 0; /* Path too long. */
8655 *cp2 = '\0'; /* Pick up with memcpy later */
8656 lcfront = lcres + (front - base);
8657 /* Now skip over each ellipsis and try to match the path in front of it. */
8659 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8660 if (*(cp1) == '.' && *(cp1+1) == '.' &&
8661 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
8662 if (cp1 < template) break; /* template started with an ellipsis */
8663 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8664 ellipsis = cp1; continue;
8666 wilddsc.dsc$a_pointer = tpl;
8667 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8669 for (segdirs = 0, cp2 = tpl;
8670 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8672 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8674 if (!decc_efs_case_preserve) {
8675 *cp2 = _tolower(*cp1); /* else lowercase for match */
8678 *cp2 = *cp1; /* else preserve case for match */
8681 if (*cp2 == '/') segdirs++;
8683 if (cp1 != ellipsis - 1) {
8685 PerlMem_free(unixified);
8686 PerlMem_free(unixwild);
8687 PerlMem_free(lcres);
8688 return 0; /* Path too long */
8690 /* Back up at least as many dirs as in template before matching */
8691 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8692 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8693 for (match = 0; cp1 > lcres;) {
8694 resdsc.dsc$a_pointer = cp1;
8695 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8697 if (match == 1) lcfront = cp1;
8699 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8703 PerlMem_free(unixified);
8704 PerlMem_free(unixwild);
8705 PerlMem_free(lcres);
8706 return 0; /* Can't find prefix ??? */
8708 if (match > 1 && opts & 1) {
8709 /* This ... wildcard could cover more than one set of dirs (i.e.
8710 * a set of similar dir names is repeated). If the template
8711 * contains more than 1 ..., upstream elements could resolve the
8712 * ambiguity, but it's not worth a full backtracking setup here.
8713 * As a quick heuristic, clip off the current default directory
8714 * if it's present to find the trimmed spec, else use the
8715 * shortest string that this ... could cover.
8717 char def[NAM$C_MAXRSS+1], *st;
8719 if (getcwd(def, sizeof def,0) == NULL) {
8720 Safefree(unixified);
8726 if (!decc_efs_case_preserve) {
8727 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8728 if (_tolower(*cp1) != _tolower(*cp2)) break;
8730 segdirs = dirs - totells; /* Min # of dirs we must have left */
8731 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8732 if (*cp1 == '\0' && *cp2 == '/') {
8733 memmove(fspec,cp2+1,end - cp2);
8735 PerlMem_free(unixified);
8736 PerlMem_free(unixwild);
8737 PerlMem_free(lcres);
8740 /* Nope -- stick with lcfront from above and keep going. */
8743 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8745 PerlMem_free(unixified);
8746 PerlMem_free(unixwild);
8747 PerlMem_free(lcres);
8752 } /* end of trim_unixpath() */
8757 * VMS readdir() routines.
8758 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8760 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
8761 * Minor modifications to original routines.
8764 /* readdir may have been redefined by reentr.h, so make sure we get
8765 * the local version for what we do here.
8770 #if !defined(PERL_IMPLICIT_CONTEXT)
8771 # define readdir Perl_readdir
8773 # define readdir(a) Perl_readdir(aTHX_ a)
8776 /* Number of elements in vms_versions array */
8777 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
8780 * Open a directory, return a handle for later use.
8782 /*{{{ DIR *opendir(char*name) */
8784 Perl_opendir(pTHX_ const char *name)
8790 Newx(dir, VMS_MAXRSS, char);
8791 if (do_tovmspath(name,dir,0,NULL) == NULL) {
8795 /* Check access before stat; otherwise stat does not
8796 * accurately report whether it's a directory.
8798 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8799 /* cando_by_name has already set errno */
8803 if (flex_stat(dir,&sb) == -1) return NULL;
8804 if (!S_ISDIR(sb.st_mode)) {
8806 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
8809 /* Get memory for the handle, and the pattern. */
8811 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8813 /* Fill in the fields; mainly playing with the descriptor. */
8814 sprintf(dd->pattern, "%s*.*",dir);
8819 /* By saying we always want the result of readdir() in unix format, we
8820 * are really saying we want all the escapes removed. Otherwise the caller,
8821 * having no way to know whether it's already in VMS format, might send it
8822 * through tovmsspec again, thus double escaping.
8824 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8825 dd->pat.dsc$a_pointer = dd->pattern;
8826 dd->pat.dsc$w_length = strlen(dd->pattern);
8827 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8828 dd->pat.dsc$b_class = DSC$K_CLASS_S;
8829 #if defined(USE_ITHREADS)
8830 Newx(dd->mutex,1,perl_mutex);
8831 MUTEX_INIT( (perl_mutex *) dd->mutex );
8837 } /* end of opendir() */
8841 * Set the flag to indicate we want versions or not.
8843 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8845 vmsreaddirversions(DIR *dd, int flag)
8848 dd->flags |= PERL_VMSDIR_M_VERSIONS;
8850 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8855 * Free up an opened directory.
8857 /*{{{ void closedir(DIR *dd)*/
8859 Perl_closedir(DIR *dd)
8863 sts = lib$find_file_end(&dd->context);
8864 Safefree(dd->pattern);
8865 #if defined(USE_ITHREADS)
8866 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8867 Safefree(dd->mutex);
8874 * Collect all the version numbers for the current file.
8877 collectversions(pTHX_ DIR *dd)
8879 struct dsc$descriptor_s pat;
8880 struct dsc$descriptor_s res;
8882 char *p, *text, *buff;
8884 unsigned long context, tmpsts;
8886 /* Convenient shorthand. */
8889 /* Add the version wildcard, ignoring the "*.*" put on before */
8890 i = strlen(dd->pattern);
8891 Newx(text,i + e->d_namlen + 3,char);
8892 strcpy(text, dd->pattern);
8893 sprintf(&text[i - 3], "%s;*", e->d_name);
8895 /* Set up the pattern descriptor. */
8896 pat.dsc$a_pointer = text;
8897 pat.dsc$w_length = i + e->d_namlen - 1;
8898 pat.dsc$b_dtype = DSC$K_DTYPE_T;
8899 pat.dsc$b_class = DSC$K_CLASS_S;
8901 /* Set up result descriptor. */
8902 Newx(buff, VMS_MAXRSS, char);
8903 res.dsc$a_pointer = buff;
8904 res.dsc$w_length = VMS_MAXRSS - 1;
8905 res.dsc$b_dtype = DSC$K_DTYPE_T;
8906 res.dsc$b_class = DSC$K_CLASS_S;
8908 /* Read files, collecting versions. */
8909 for (context = 0, e->vms_verscount = 0;
8910 e->vms_verscount < VERSIZE(e);
8911 e->vms_verscount++) {
8913 unsigned long flags = 0;
8915 #ifdef VMS_LONGNAME_SUPPORT
8916 flags = LIB$M_FIL_LONG_NAMES;
8918 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8919 if (tmpsts == RMS$_NMF || context == 0) break;
8921 buff[VMS_MAXRSS - 1] = '\0';
8922 if ((p = strchr(buff, ';')))
8923 e->vms_versions[e->vms_verscount] = atoi(p + 1);
8925 e->vms_versions[e->vms_verscount] = -1;
8928 _ckvmssts(lib$find_file_end(&context));
8932 } /* end of collectversions() */
8935 * Read the next entry from the directory.
8937 /*{{{ struct dirent *readdir(DIR *dd)*/
8939 Perl_readdir(pTHX_ DIR *dd)
8941 struct dsc$descriptor_s res;
8943 unsigned long int tmpsts;
8945 unsigned long flags = 0;
8946 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8947 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8949 /* Set up result descriptor, and get next file. */
8950 Newx(buff, VMS_MAXRSS, char);
8951 res.dsc$a_pointer = buff;
8952 res.dsc$w_length = VMS_MAXRSS - 1;
8953 res.dsc$b_dtype = DSC$K_DTYPE_T;
8954 res.dsc$b_class = DSC$K_CLASS_S;
8956 #ifdef VMS_LONGNAME_SUPPORT
8957 flags = LIB$M_FIL_LONG_NAMES;
8960 tmpsts = lib$find_file
8961 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8962 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
8963 if (!(tmpsts & 1)) {
8964 set_vaxc_errno(tmpsts);
8967 set_errno(EACCES); break;
8969 set_errno(ENODEV); break;
8971 set_errno(ENOTDIR); break;
8972 case RMS$_FNF: case RMS$_DNF:
8973 set_errno(ENOENT); break;
8981 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8982 if (!decc_efs_case_preserve) {
8983 buff[VMS_MAXRSS - 1] = '\0';
8984 for (p = buff; *p; p++) *p = _tolower(*p);
8987 /* we don't want to force to lowercase, just null terminate */
8988 buff[res.dsc$w_length] = '\0';
8990 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
8993 /* Skip any directory component and just copy the name. */
8994 sts = vms_split_path
9009 /* Drop NULL extensions on UNIX file specification */
9010 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9011 (e_len == 1) && decc_readdir_dropdotnotype)) {
9016 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9017 dd->entry.d_name[n_len + e_len] = '\0';
9018 dd->entry.d_namlen = strlen(dd->entry.d_name);
9020 /* Convert the filename to UNIX format if needed */
9021 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9023 /* Translate the encoded characters. */
9024 /* Fixme: Unicode handling could result in embedded 0 characters */
9025 if (strchr(dd->entry.d_name, '^') != NULL) {
9028 p = dd->entry.d_name;
9031 int inchars_read, outchars_added;
9032 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9034 q += outchars_added;
9036 /* if outchars_added > 1, then this is a wide file specification */
9037 /* Wide file specifications need to be passed in Perl */
9038 /* counted strings apparently with a Unicode flag */
9041 strcpy(dd->entry.d_name, new_name);
9042 dd->entry.d_namlen = strlen(dd->entry.d_name);
9046 dd->entry.vms_verscount = 0;
9047 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9051 } /* end of readdir() */
9055 * Read the next entry from the directory -- thread-safe version.
9057 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9059 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9063 MUTEX_LOCK( (perl_mutex *) dd->mutex );
9065 entry = readdir(dd);
9067 retval = ( *result == NULL ? errno : 0 );
9069 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9073 } /* end of readdir_r() */
9077 * Return something that can be used in a seekdir later.
9079 /*{{{ long telldir(DIR *dd)*/
9081 Perl_telldir(DIR *dd)
9088 * Return to a spot where we used to be. Brute force.
9090 /*{{{ void seekdir(DIR *dd,long count)*/
9092 Perl_seekdir(pTHX_ DIR *dd, long count)
9096 /* If we haven't done anything yet... */
9100 /* Remember some state, and clear it. */
9101 old_flags = dd->flags;
9102 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9103 _ckvmssts(lib$find_file_end(&dd->context));
9106 /* The increment is in readdir(). */
9107 for (dd->count = 0; dd->count < count; )
9110 dd->flags = old_flags;
9112 } /* end of seekdir() */
9115 /* VMS subprocess management
9117 * my_vfork() - just a vfork(), after setting a flag to record that
9118 * the current script is trying a Unix-style fork/exec.
9120 * vms_do_aexec() and vms_do_exec() are called in response to the
9121 * perl 'exec' function. If this follows a vfork call, then they
9122 * call out the regular perl routines in doio.c which do an
9123 * execvp (for those who really want to try this under VMS).
9124 * Otherwise, they do exactly what the perl docs say exec should
9125 * do - terminate the current script and invoke a new command
9126 * (See below for notes on command syntax.)
9128 * do_aspawn() and do_spawn() implement the VMS side of the perl
9129 * 'system' function.
9131 * Note on command arguments to perl 'exec' and 'system': When handled
9132 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9133 * are concatenated to form a DCL command string. If the first arg
9134 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9135 * the command string is handed off to DCL directly. Otherwise,
9136 * the first token of the command is taken as the filespec of an image
9137 * to run. The filespec is expanded using a default type of '.EXE' and
9138 * the process defaults for device, directory, etc., and if found, the resultant
9139 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9140 * the command string as parameters. This is perhaps a bit complicated,
9141 * but I hope it will form a happy medium between what VMS folks expect
9142 * from lib$spawn and what Unix folks expect from exec.
9145 static int vfork_called;
9147 /*{{{int my_vfork()*/
9158 vms_execfree(struct dsc$descriptor_s *vmscmd)
9161 if (vmscmd->dsc$a_pointer) {
9162 PerlMem_free(vmscmd->dsc$a_pointer);
9164 PerlMem_free(vmscmd);
9169 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9171 char *junk, *tmps = Nullch;
9172 register size_t cmdlen = 0;
9179 tmps = SvPV(really,rlen);
9186 for (idx++; idx <= sp; idx++) {
9188 junk = SvPVx(*idx,rlen);
9189 cmdlen += rlen ? rlen + 1 : 0;
9192 Newx(PL_Cmd, cmdlen+1, char);
9194 if (tmps && *tmps) {
9195 strcpy(PL_Cmd,tmps);
9198 else *PL_Cmd = '\0';
9199 while (++mark <= sp) {
9201 char *s = SvPVx(*mark,n_a);
9203 if (*PL_Cmd) strcat(PL_Cmd," ");
9209 } /* end of setup_argstr() */
9212 static unsigned long int
9213 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9214 struct dsc$descriptor_s **pvmscmd)
9216 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9217 char image_name[NAM$C_MAXRSS+1];
9218 char image_argv[NAM$C_MAXRSS+1];
9219 $DESCRIPTOR(defdsc,".EXE");
9220 $DESCRIPTOR(defdsc2,".");
9221 $DESCRIPTOR(resdsc,resspec);
9222 struct dsc$descriptor_s *vmscmd;
9223 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9224 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9225 register char *s, *rest, *cp, *wordbreak;
9230 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9231 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9233 /* Make a copy for modification */
9234 cmdlen = strlen(incmd);
9235 cmd = PerlMem_malloc(cmdlen+1);
9236 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9237 strncpy(cmd, incmd, cmdlen);
9242 vmscmd->dsc$a_pointer = NULL;
9243 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
9244 vmscmd->dsc$b_class = DSC$K_CLASS_S;
9245 vmscmd->dsc$w_length = 0;
9246 if (pvmscmd) *pvmscmd = vmscmd;
9248 if (suggest_quote) *suggest_quote = 0;
9250 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9252 return CLI$_BUFOVF; /* continuation lines currently unsupported */
9257 while (*s && isspace(*s)) s++;
9259 if (*s == '@' || *s == '$') {
9260 vmsspec[0] = *s; rest = s + 1;
9261 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9263 else { cp = vmsspec; rest = s; }
9264 if (*rest == '.' || *rest == '/') {
9267 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9268 rest++, cp2++) *cp2 = *rest;
9270 if (do_tovmsspec(resspec,cp,0,NULL)) {
9273 for (cp2 = vmsspec + strlen(vmsspec);
9274 *rest && cp2 - vmsspec < sizeof vmsspec;
9275 rest++, cp2++) *cp2 = *rest;
9280 /* Intuit whether verb (first word of cmd) is a DCL command:
9281 * - if first nonspace char is '@', it's a DCL indirection
9283 * - if verb contains a filespec separator, it's not a DCL command
9284 * - if it doesn't, caller tells us whether to default to a DCL
9285 * command, or to a local image unless told it's DCL (by leading '$')
9289 if (suggest_quote) *suggest_quote = 1;
9291 register char *filespec = strpbrk(s,":<[.;");
9292 rest = wordbreak = strpbrk(s," \"\t/");
9293 if (!wordbreak) wordbreak = s + strlen(s);
9294 if (*s == '$') check_img = 0;
9295 if (filespec && (filespec < wordbreak)) isdcl = 0;
9296 else isdcl = !check_img;
9301 imgdsc.dsc$a_pointer = s;
9302 imgdsc.dsc$w_length = wordbreak - s;
9303 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9305 _ckvmssts(lib$find_file_end(&cxt));
9306 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9307 if (!(retsts & 1) && *s == '$') {
9308 _ckvmssts(lib$find_file_end(&cxt));
9309 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9310 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9312 _ckvmssts(lib$find_file_end(&cxt));
9313 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9317 _ckvmssts(lib$find_file_end(&cxt));
9322 while (*s && !isspace(*s)) s++;
9325 /* check that it's really not DCL with no file extension */
9326 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9328 char b[256] = {0,0,0,0};
9329 read(fileno(fp), b, 256);
9330 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9334 /* Check for script */
9336 if ((b[0] == '#') && (b[1] == '!'))
9338 #ifdef ALTERNATE_SHEBANG
9340 shebang_len = strlen(ALTERNATE_SHEBANG);
9341 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9343 perlstr = strstr("perl",b);
9344 if (perlstr == NULL)
9352 if (shebang_len > 0) {
9355 char tmpspec[NAM$C_MAXRSS + 1];
9358 /* Image is following after white space */
9359 /*--------------------------------------*/
9360 while (isprint(b[i]) && isspace(b[i]))
9364 while (isprint(b[i]) && !isspace(b[i])) {
9365 tmpspec[j++] = b[i++];
9366 if (j >= NAM$C_MAXRSS)
9371 /* There may be some default parameters to the image */
9372 /*---------------------------------------------------*/
9374 while (isprint(b[i])) {
9375 image_argv[j++] = b[i++];
9376 if (j >= NAM$C_MAXRSS)
9379 while ((j > 0) && !isprint(image_argv[j-1]))
9383 /* It will need to be converted to VMS format and validated */
9384 if (tmpspec[0] != '\0') {
9387 /* Try to find the exact program requested to be run */
9388 /*---------------------------------------------------*/
9389 iname = do_rmsexpand
9390 (tmpspec, image_name, 0, ".exe",
9391 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9392 if (iname != NULL) {
9393 if (cando_by_name_int
9394 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9395 /* MCR prefix needed */
9399 /* Try again with a null type */
9400 /*----------------------------*/
9401 iname = do_rmsexpand
9402 (tmpspec, image_name, 0, ".",
9403 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9404 if (iname != NULL) {
9405 if (cando_by_name_int
9406 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9407 /* MCR prefix needed */
9413 /* Did we find the image to run the script? */
9414 /*------------------------------------------*/
9418 /* Assume DCL or foreign command exists */
9419 /*--------------------------------------*/
9420 tchr = strrchr(tmpspec, '/');
9427 strcpy(image_name, tchr);
9435 if (check_img && isdcl) return RMS$_FNF;
9437 if (cando_by_name(S_IXUSR,0,resspec)) {
9438 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9439 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9441 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9442 if (image_name[0] != 0) {
9443 strcat(vmscmd->dsc$a_pointer, image_name);
9444 strcat(vmscmd->dsc$a_pointer, " ");
9446 } else if (image_name[0] != 0) {
9447 strcpy(vmscmd->dsc$a_pointer, image_name);
9448 strcat(vmscmd->dsc$a_pointer, " ");
9450 strcpy(vmscmd->dsc$a_pointer,"@");
9452 if (suggest_quote) *suggest_quote = 1;
9454 /* If there is an image name, use original command */
9455 if (image_name[0] == 0)
9456 strcat(vmscmd->dsc$a_pointer,resspec);
9459 while (*rest && isspace(*rest)) rest++;
9462 if (image_argv[0] != 0) {
9463 strcat(vmscmd->dsc$a_pointer,image_argv);
9464 strcat(vmscmd->dsc$a_pointer, " ");
9470 rest_len = strlen(rest);
9471 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9472 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9473 strcat(vmscmd->dsc$a_pointer,rest);
9475 retsts = CLI$_BUFOVF;
9477 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9479 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9485 /* It's either a DCL command or we couldn't find a suitable image */
9486 vmscmd->dsc$w_length = strlen(cmd);
9488 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9489 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9490 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9494 /* check if it's a symbol (for quoting purposes) */
9495 if (suggest_quote && !*suggest_quote) {
9497 char equiv[LNM$C_NAMLENGTH];
9498 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9499 eqvdsc.dsc$a_pointer = equiv;
9501 iss = lib$get_symbol(vmscmd,&eqvdsc);
9502 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9504 if (!(retsts & 1)) {
9505 /* just hand off status values likely to be due to user error */
9506 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9507 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9508 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9509 else { _ckvmssts(retsts); }
9512 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9514 } /* end of setup_cmddsc() */
9517 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9519 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9525 if (vfork_called) { /* this follows a vfork - act Unixish */
9527 if (vfork_called < 0) {
9528 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9531 else return do_aexec(really,mark,sp);
9533 /* no vfork - act VMSish */
9534 cmd = setup_argstr(aTHX_ really,mark,sp);
9535 exec_sts = vms_do_exec(cmd);
9536 Safefree(cmd); /* Clean up from setup_argstr() */
9541 } /* end of vms_do_aexec() */
9544 /* {{{bool vms_do_exec(char *cmd) */
9546 Perl_vms_do_exec(pTHX_ const char *cmd)
9548 struct dsc$descriptor_s *vmscmd;
9550 if (vfork_called) { /* this follows a vfork - act Unixish */
9552 if (vfork_called < 0) {
9553 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9556 else return do_exec(cmd);
9559 { /* no vfork - act VMSish */
9560 unsigned long int retsts;
9563 TAINT_PROPER("exec");
9564 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9565 retsts = lib$do_command(vmscmd);
9568 case RMS$_FNF: case RMS$_DNF:
9569 set_errno(ENOENT); break;
9571 set_errno(ENOTDIR); break;
9573 set_errno(ENODEV); break;
9575 set_errno(EACCES); break;
9577 set_errno(EINVAL); break;
9578 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9579 set_errno(E2BIG); break;
9580 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9581 _ckvmssts(retsts); /* fall through */
9582 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9585 set_vaxc_errno(retsts);
9586 if (ckWARN(WARN_EXEC)) {
9587 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9588 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9590 vms_execfree(vmscmd);
9595 } /* end of vms_do_exec() */
9598 unsigned long int Perl_do_spawn(pTHX_ const char *);
9600 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9602 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9604 unsigned long int sts;
9608 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9609 sts = do_spawn(cmd);
9610 /* pp_sys will clean up cmd */
9614 } /* end of do_aspawn() */
9617 /* {{{unsigned long int do_spawn(char *cmd) */
9619 Perl_do_spawn(pTHX_ const char *cmd)
9621 unsigned long int sts, substs;
9623 /* The caller of this routine expects to Safefree(PL_Cmd) */
9624 Newx(PL_Cmd,10,char);
9627 TAINT_PROPER("spawn");
9628 if (!cmd || !*cmd) {
9629 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9632 case RMS$_FNF: case RMS$_DNF:
9633 set_errno(ENOENT); break;
9635 set_errno(ENOTDIR); break;
9637 set_errno(ENODEV); break;
9639 set_errno(EACCES); break;
9641 set_errno(EINVAL); break;
9642 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9643 set_errno(E2BIG); break;
9644 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9645 _ckvmssts(sts); /* fall through */
9646 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9649 set_vaxc_errno(sts);
9650 if (ckWARN(WARN_EXEC)) {
9651 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9659 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9664 } /* end of do_spawn() */
9668 static unsigned int *sockflags, sockflagsize;
9671 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9672 * routines found in some versions of the CRTL can't deal with sockets.
9673 * We don't shim the other file open routines since a socket isn't
9674 * likely to be opened by a name.
9676 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9677 FILE *my_fdopen(int fd, const char *mode)
9679 FILE *fp = fdopen(fd, mode);
9682 unsigned int fdoff = fd / sizeof(unsigned int);
9683 Stat_t sbuf; /* native stat; we don't need flex_stat */
9684 if (!sockflagsize || fdoff > sockflagsize) {
9685 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
9686 else Newx (sockflags,fdoff+2,unsigned int);
9687 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9688 sockflagsize = fdoff + 2;
9690 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9691 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9700 * Clear the corresponding bit when the (possibly) socket stream is closed.
9701 * There still a small hole: we miss an implicit close which might occur
9702 * via freopen(). >> Todo
9704 /*{{{ int my_fclose(FILE *fp)*/
9705 int my_fclose(FILE *fp) {
9707 unsigned int fd = fileno(fp);
9708 unsigned int fdoff = fd / sizeof(unsigned int);
9710 if (sockflagsize && fdoff <= sockflagsize)
9711 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9719 * A simple fwrite replacement which outputs itmsz*nitm chars without
9720 * introducing record boundaries every itmsz chars.
9721 * We are using fputs, which depends on a terminating null. We may
9722 * well be writing binary data, so we need to accommodate not only
9723 * data with nulls sprinkled in the middle but also data with no null
9726 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9728 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9730 register char *cp, *end, *cpd, *data;
9731 register unsigned int fd = fileno(dest);
9732 register unsigned int fdoff = fd / sizeof(unsigned int);
9734 int bufsize = itmsz * nitm + 1;
9736 if (fdoff < sockflagsize &&
9737 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9738 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9742 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9743 memcpy( data, src, itmsz*nitm );
9744 data[itmsz*nitm] = '\0';
9746 end = data + itmsz * nitm;
9747 retval = (int) nitm; /* on success return # items written */
9750 while (cpd <= end) {
9751 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9752 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9754 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9758 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9761 } /* end of my_fwrite() */
9764 /*{{{ int my_flush(FILE *fp)*/
9766 Perl_my_flush(pTHX_ FILE *fp)
9769 if ((res = fflush(fp)) == 0 && fp) {
9770 #ifdef VMS_DO_SOCKETS
9772 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9774 res = fsync(fileno(fp));
9777 * If the flush succeeded but set end-of-file, we need to clear
9778 * the error because our caller may check ferror(). BTW, this
9779 * probably means we just flushed an empty file.
9781 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9788 * Here are replacements for the following Unix routines in the VMS environment:
9789 * getpwuid Get information for a particular UIC or UID
9790 * getpwnam Get information for a named user
9791 * getpwent Get information for each user in the rights database
9792 * setpwent Reset search to the start of the rights database
9793 * endpwent Finish searching for users in the rights database
9795 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9796 * (defined in pwd.h), which contains the following fields:-
9798 * char *pw_name; Username (in lower case)
9799 * char *pw_passwd; Hashed password
9800 * unsigned int pw_uid; UIC
9801 * unsigned int pw_gid; UIC group number
9802 * char *pw_unixdir; Default device/directory (VMS-style)
9803 * char *pw_gecos; Owner name
9804 * char *pw_dir; Default device/directory (Unix-style)
9805 * char *pw_shell; Default CLI name (eg. DCL)
9807 * If the specified user does not exist, getpwuid and getpwnam return NULL.
9809 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9810 * not the UIC member number (eg. what's returned by getuid()),
9811 * getpwuid() can accept either as input (if uid is specified, the caller's
9812 * UIC group is used), though it won't recognise gid=0.
9814 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9815 * information about other users in your group or in other groups, respectively.
9816 * If the required privilege is not available, then these routines fill only
9817 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9820 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9823 /* sizes of various UAF record fields */
9824 #define UAI$S_USERNAME 12
9825 #define UAI$S_IDENT 31
9826 #define UAI$S_OWNER 31
9827 #define UAI$S_DEFDEV 31
9828 #define UAI$S_DEFDIR 63
9829 #define UAI$S_DEFCLI 31
9832 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
9833 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9834 (uic).uic$v_group != UIC$K_WILD_GROUP)
9836 static char __empty[]= "";
9837 static struct passwd __passwd_empty=
9838 {(char *) __empty, (char *) __empty, 0, 0,
9839 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9840 static int contxt= 0;
9841 static struct passwd __pwdcache;
9842 static char __pw_namecache[UAI$S_IDENT+1];
9845 * This routine does most of the work extracting the user information.
9847 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9850 unsigned char length;
9851 char pw_gecos[UAI$S_OWNER+1];
9853 static union uicdef uic;
9855 unsigned char length;
9856 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9859 unsigned char length;
9860 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9863 unsigned char length;
9864 char pw_shell[UAI$S_DEFCLI+1];
9866 static char pw_passwd[UAI$S_PWD+1];
9868 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9869 struct dsc$descriptor_s name_desc;
9870 unsigned long int sts;
9872 static struct itmlst_3 itmlst[]= {
9873 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
9874 {sizeof(uic), UAI$_UIC, &uic, &luic},
9875 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
9876 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
9877 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
9878 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
9879 {0, 0, NULL, NULL}};
9881 name_desc.dsc$w_length= strlen(name);
9882 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9883 name_desc.dsc$b_class= DSC$K_CLASS_S;
9884 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9886 /* Note that sys$getuai returns many fields as counted strings. */
9887 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9888 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9889 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9891 else { _ckvmssts(sts); }
9892 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
9894 if ((int) owner.length < lowner) lowner= (int) owner.length;
9895 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9896 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9897 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9898 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9899 owner.pw_gecos[lowner]= '\0';
9900 defdev.pw_dir[ldefdev+ldefdir]= '\0';
9901 defcli.pw_shell[ldefcli]= '\0';
9902 if (valid_uic(uic)) {
9903 pwd->pw_uid= uic.uic$l_uic;
9904 pwd->pw_gid= uic.uic$v_group;
9907 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9908 pwd->pw_passwd= pw_passwd;
9909 pwd->pw_gecos= owner.pw_gecos;
9910 pwd->pw_dir= defdev.pw_dir;
9911 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9912 pwd->pw_shell= defcli.pw_shell;
9913 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9915 ldir= strlen(pwd->pw_unixdir) - 1;
9916 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9919 strcpy(pwd->pw_unixdir, pwd->pw_dir);
9920 if (!decc_efs_case_preserve)
9921 __mystrtolower(pwd->pw_unixdir);
9926 * Get information for a named user.
9928 /*{{{struct passwd *getpwnam(char *name)*/
9929 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9931 struct dsc$descriptor_s name_desc;
9933 unsigned long int status, sts;
9935 __pwdcache = __passwd_empty;
9936 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9937 /* We still may be able to determine pw_uid and pw_gid */
9938 name_desc.dsc$w_length= strlen(name);
9939 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9940 name_desc.dsc$b_class= DSC$K_CLASS_S;
9941 name_desc.dsc$a_pointer= (char *) name;
9942 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9943 __pwdcache.pw_uid= uic.uic$l_uic;
9944 __pwdcache.pw_gid= uic.uic$v_group;
9947 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9948 set_vaxc_errno(sts);
9949 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9952 else { _ckvmssts(sts); }
9955 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9956 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9957 __pwdcache.pw_name= __pw_namecache;
9959 } /* end of my_getpwnam() */
9963 * Get information for a particular UIC or UID.
9964 * Called by my_getpwent with uid=-1 to list all users.
9966 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9967 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9969 const $DESCRIPTOR(name_desc,__pw_namecache);
9970 unsigned short lname;
9972 unsigned long int status;
9974 if (uid == (unsigned int) -1) {
9976 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9977 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9978 set_vaxc_errno(status);
9979 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9983 else { _ckvmssts(status); }
9984 } while (!valid_uic (uic));
9988 if (!uic.uic$v_group)
9989 uic.uic$v_group= PerlProc_getgid();
9991 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9992 else status = SS$_IVIDENT;
9993 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9994 status == RMS$_PRV) {
9995 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9998 else { _ckvmssts(status); }
10000 __pw_namecache[lname]= '\0';
10001 __mystrtolower(__pw_namecache);
10003 __pwdcache = __passwd_empty;
10004 __pwdcache.pw_name = __pw_namecache;
10006 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10007 The identifier's value is usually the UIC, but it doesn't have to be,
10008 so if we can, we let fillpasswd update this. */
10009 __pwdcache.pw_uid = uic.uic$l_uic;
10010 __pwdcache.pw_gid = uic.uic$v_group;
10012 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10013 return &__pwdcache;
10015 } /* end of my_getpwuid() */
10019 * Get information for next user.
10021 /*{{{struct passwd *my_getpwent()*/
10022 struct passwd *Perl_my_getpwent(pTHX)
10024 return (my_getpwuid((unsigned int) -1));
10029 * Finish searching rights database for users.
10031 /*{{{void my_endpwent()*/
10032 void Perl_my_endpwent(pTHX)
10035 _ckvmssts(sys$finish_rdb(&contxt));
10041 #ifdef HOMEGROWN_POSIX_SIGNALS
10042 /* Signal handling routines, pulled into the core from POSIX.xs.
10044 * We need these for threads, so they've been rolled into the core,
10045 * rather than left in POSIX.xs.
10047 * (DRS, Oct 23, 1997)
10050 /* sigset_t is atomic under VMS, so these routines are easy */
10051 /*{{{int my_sigemptyset(sigset_t *) */
10052 int my_sigemptyset(sigset_t *set) {
10053 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10054 *set = 0; return 0;
10059 /*{{{int my_sigfillset(sigset_t *)*/
10060 int my_sigfillset(sigset_t *set) {
10062 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10063 for (i = 0; i < NSIG; i++) *set |= (1 << i);
10069 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10070 int my_sigaddset(sigset_t *set, int sig) {
10071 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10072 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10073 *set |= (1 << (sig - 1));
10079 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10080 int my_sigdelset(sigset_t *set, int sig) {
10081 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10082 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10083 *set &= ~(1 << (sig - 1));
10089 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10090 int my_sigismember(sigset_t *set, int sig) {
10091 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10092 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10093 return *set & (1 << (sig - 1));
10098 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10099 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10102 /* If set and oset are both null, then things are badly wrong. Bail out. */
10103 if ((oset == NULL) && (set == NULL)) {
10104 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10108 /* If set's null, then we're just handling a fetch. */
10110 tempmask = sigblock(0);
10115 tempmask = sigsetmask(*set);
10118 tempmask = sigblock(*set);
10121 tempmask = sigblock(0);
10122 sigsetmask(*oset & ~tempmask);
10125 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10130 /* Did they pass us an oset? If so, stick our holding mask into it */
10137 #endif /* HOMEGROWN_POSIX_SIGNALS */
10140 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10141 * my_utime(), and flex_stat(), all of which operate on UTC unless
10142 * VMSISH_TIMES is true.
10144 /* method used to handle UTC conversions:
10145 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
10147 static int gmtime_emulation_type;
10148 /* number of secs to add to UTC POSIX-style time to get local time */
10149 static long int utc_offset_secs;
10151 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10152 * in vmsish.h. #undef them here so we can call the CRTL routines
10161 * DEC C previous to 6.0 corrupts the behavior of the /prefix
10162 * qualifier with the extern prefix pragma. This provisional
10163 * hack circumvents this prefix pragma problem in previous
10166 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10167 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10168 # pragma __extern_prefix save
10169 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
10170 # define gmtime decc$__utctz_gmtime
10171 # define localtime decc$__utctz_localtime
10172 # define time decc$__utc_time
10173 # pragma __extern_prefix restore
10175 struct tm *gmtime(), *localtime();
10181 static time_t toutc_dst(time_t loc) {
10184 if ((rsltmp = localtime(&loc)) == NULL) return -1;
10185 loc -= utc_offset_secs;
10186 if (rsltmp->tm_isdst) loc -= 3600;
10189 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10190 ((gmtime_emulation_type || my_time(NULL)), \
10191 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10192 ((secs) - utc_offset_secs))))
10194 static time_t toloc_dst(time_t utc) {
10197 utc += utc_offset_secs;
10198 if ((rsltmp = localtime(&utc)) == NULL) return -1;
10199 if (rsltmp->tm_isdst) utc += 3600;
10202 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10203 ((gmtime_emulation_type || my_time(NULL)), \
10204 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10205 ((secs) + utc_offset_secs))))
10207 #ifndef RTL_USES_UTC
10210 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
10211 DST starts on 1st sun of april at 02:00 std time
10212 ends on last sun of october at 02:00 dst time
10213 see the UCX management command reference, SET CONFIG TIMEZONE
10214 for formatting info.
10216 No, it's not as general as it should be, but then again, NOTHING
10217 will handle UK times in a sensible way.
10222 parse the DST start/end info:
10223 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10227 tz_parse_startend(char *s, struct tm *w, int *past)
10229 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10230 int ly, dozjd, d, m, n, hour, min, sec, j, k;
10235 if (!past) return 0;
10238 if (w->tm_year % 4 == 0) ly = 1;
10239 if (w->tm_year % 100 == 0) ly = 0;
10240 if (w->tm_year+1900 % 400 == 0) ly = 1;
10243 dozjd = isdigit(*s);
10244 if (*s == 'J' || *s == 'j' || dozjd) {
10245 if (!dozjd && !isdigit(*++s)) return 0;
10248 d = d*10 + *s++ - '0';
10250 d = d*10 + *s++ - '0';
10253 if (d == 0) return 0;
10254 if (d > 366) return 0;
10256 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
10259 } else if (*s == 'M' || *s == 'm') {
10260 if (!isdigit(*++s)) return 0;
10262 if (isdigit(*s)) m = 10*m + *s++ - '0';
10263 if (*s != '.') return 0;
10264 if (!isdigit(*++s)) return 0;
10266 if (n < 1 || n > 5) return 0;
10267 if (*s != '.') return 0;
10268 if (!isdigit(*++s)) return 0;
10270 if (d > 6) return 0;
10274 if (!isdigit(*++s)) return 0;
10276 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10278 if (!isdigit(*++s)) return 0;
10280 if (isdigit(*s)) min = 10*min + *s++ - '0';
10282 if (!isdigit(*++s)) return 0;
10284 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10294 if (w->tm_yday < d) goto before;
10295 if (w->tm_yday > d) goto after;
10297 if (w->tm_mon+1 < m) goto before;
10298 if (w->tm_mon+1 > m) goto after;
10300 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
10301 k = d - j; /* mday of first d */
10302 if (k <= 0) k += 7;
10303 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
10304 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10305 if (w->tm_mday < k) goto before;
10306 if (w->tm_mday > k) goto after;
10309 if (w->tm_hour < hour) goto before;
10310 if (w->tm_hour > hour) goto after;
10311 if (w->tm_min < min) goto before;
10312 if (w->tm_min > min) goto after;
10313 if (w->tm_sec < sec) goto before;
10327 /* parse the offset: (+|-)hh[:mm[:ss]] */
10330 tz_parse_offset(char *s, int *offset)
10332 int hour = 0, min = 0, sec = 0;
10335 if (!offset) return 0;
10337 if (*s == '-') {neg++; s++;}
10338 if (*s == '+') s++;
10339 if (!isdigit(*s)) return 0;
10341 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10342 if (hour > 24) return 0;
10344 if (!isdigit(*++s)) return 0;
10346 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10347 if (min > 59) return 0;
10349 if (!isdigit(*++s)) return 0;
10351 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10352 if (sec > 59) return 0;
10356 *offset = (hour*60+min)*60 + sec;
10357 if (neg) *offset = -*offset;
10362 input time is w, whatever type of time the CRTL localtime() uses.
10363 sets dst, the zone, and the gmtoff (seconds)
10365 caches the value of TZ and UCX$TZ env variables; note that
10366 my_setenv looks for these and sets a flag if they're changed
10369 We have to watch out for the "australian" case (dst starts in
10370 october, ends in april)...flagged by "reverse" and checked by
10371 scanning through the months of the previous year.
10376 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10381 char *dstzone, *tz, *s_start, *s_end;
10382 int std_off, dst_off, isdst;
10383 int y, dststart, dstend;
10384 static char envtz[1025]; /* longer than any logical, symbol, ... */
10385 static char ucxtz[1025];
10386 static char reversed = 0;
10392 reversed = -1; /* flag need to check */
10393 envtz[0] = ucxtz[0] = '\0';
10394 tz = my_getenv("TZ",0);
10395 if (tz) strcpy(envtz, tz);
10396 tz = my_getenv("UCX$TZ",0);
10397 if (tz) strcpy(ucxtz, tz);
10398 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
10401 if (!*tz) tz = ucxtz;
10404 while (isalpha(*s)) s++;
10405 s = tz_parse_offset(s, &std_off);
10407 if (!*s) { /* no DST, hurray we're done! */
10413 while (isalpha(*s)) s++;
10414 s2 = tz_parse_offset(s, &dst_off);
10418 dst_off = std_off - 3600;
10421 if (!*s) { /* default dst start/end?? */
10422 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
10423 s = strchr(ucxtz,',');
10425 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
10427 if (*s != ',') return 0;
10430 when = _toutc(when); /* convert to utc */
10431 when = when - std_off; /* convert to pseudolocal time*/
10433 w2 = localtime(&when);
10436 s = tz_parse_startend(s_start,w2,&dststart);
10438 if (*s != ',') return 0;
10441 when = _toutc(when); /* convert to utc */
10442 when = when - dst_off; /* convert to pseudolocal time*/
10443 w2 = localtime(&when);
10444 if (w2->tm_year != y) { /* spans a year, just check one time */
10445 when += dst_off - std_off;
10446 w2 = localtime(&when);
10449 s = tz_parse_startend(s_end,w2,&dstend);
10452 if (reversed == -1) { /* need to check if start later than end */
10456 if (when < 2*365*86400) {
10457 when += 2*365*86400;
10461 w2 =localtime(&when);
10462 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
10464 for (j = 0; j < 12; j++) {
10465 w2 =localtime(&when);
10466 tz_parse_startend(s_start,w2,&ds);
10467 tz_parse_startend(s_end,w2,&de);
10468 if (ds != de) break;
10472 if (de && !ds) reversed = 1;
10475 isdst = dststart && !dstend;
10476 if (reversed) isdst = dststart || !dstend;
10479 if (dst) *dst = isdst;
10480 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10481 if (isdst) tz = dstzone;
10483 while(isalpha(*tz)) *zone++ = *tz++;
10489 #endif /* !RTL_USES_UTC */
10491 /* my_time(), my_localtime(), my_gmtime()
10492 * By default traffic in UTC time values, using CRTL gmtime() or
10493 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10494 * Note: We need to use these functions even when the CRTL has working
10495 * UTC support, since they also handle C<use vmsish qw(times);>
10497 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
10498 * Modified by Charles Bailey <bailey@newman.upenn.edu>
10501 /*{{{time_t my_time(time_t *timep)*/
10502 time_t Perl_my_time(pTHX_ time_t *timep)
10507 if (gmtime_emulation_type == 0) {
10509 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
10510 /* results of calls to gmtime() and localtime() */
10511 /* for same &base */
10513 gmtime_emulation_type++;
10514 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10515 char off[LNM$C_NAMLENGTH+1];;
10517 gmtime_emulation_type++;
10518 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10519 gmtime_emulation_type++;
10520 utc_offset_secs = 0;
10521 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10523 else { utc_offset_secs = atol(off); }
10525 else { /* We've got a working gmtime() */
10526 struct tm gmt, local;
10529 tm_p = localtime(&base);
10531 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
10532 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10533 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
10534 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
10539 # ifdef VMSISH_TIME
10540 # ifdef RTL_USES_UTC
10541 if (VMSISH_TIME) when = _toloc(when);
10543 if (!VMSISH_TIME) when = _toutc(when);
10546 if (timep != NULL) *timep = when;
10549 } /* end of my_time() */
10553 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10555 Perl_my_gmtime(pTHX_ const time_t *timep)
10561 if (timep == NULL) {
10562 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10565 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10568 # ifdef VMSISH_TIME
10569 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10571 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
10572 return gmtime(&when);
10574 /* CRTL localtime() wants local time as input, so does no tz correction */
10575 rsltmp = localtime(&when);
10576 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
10579 } /* end of my_gmtime() */
10583 /*{{{struct tm *my_localtime(const time_t *timep)*/
10585 Perl_my_localtime(pTHX_ const time_t *timep)
10587 time_t when, whenutc;
10591 if (timep == NULL) {
10592 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10595 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10596 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10599 # ifdef RTL_USES_UTC
10600 # ifdef VMSISH_TIME
10601 if (VMSISH_TIME) when = _toutc(when);
10603 /* CRTL localtime() wants UTC as input, does tz correction itself */
10604 return localtime(&when);
10606 # else /* !RTL_USES_UTC */
10608 # ifdef VMSISH_TIME
10609 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
10610 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
10613 #ifndef RTL_USES_UTC
10614 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
10615 when = whenutc - offset; /* pseudolocal time*/
10618 /* CRTL localtime() wants local time as input, so does no tz correction */
10619 rsltmp = localtime(&when);
10620 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10624 } /* end of my_localtime() */
10627 /* Reset definitions for later calls */
10628 #define gmtime(t) my_gmtime(t)
10629 #define localtime(t) my_localtime(t)
10630 #define time(t) my_time(t)
10633 /* my_utime - update modification/access time of a file
10635 * VMS 7.3 and later implementation
10636 * Only the UTC translation is home-grown. The rest is handled by the
10637 * CRTL utime(), which will take into account the relevant feature
10638 * logicals and ODS-5 volume characteristics for true access times.
10640 * pre VMS 7.3 implementation:
10641 * The calling sequence is identical to POSIX utime(), but under
10642 * VMS with ODS-2, only the modification time is changed; ODS-2 does
10643 * not maintain access times. Restrictions differ from the POSIX
10644 * definition in that the time can be changed as long as the
10645 * caller has permission to execute the necessary IO$_MODIFY $QIO;
10646 * no separate checks are made to insure that the caller is the
10647 * owner of the file or has special privs enabled.
10648 * Code here is based on Joe Meadows' FILE utility.
10652 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10653 * to VMS epoch (01-JAN-1858 00:00:00.00)
10654 * in 100 ns intervals.
10656 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10658 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10659 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10661 #if __CRTL_VER >= 70300000
10662 struct utimbuf utc_utimes, *utc_utimesp;
10664 if (utimes != NULL) {
10665 utc_utimes.actime = utimes->actime;
10666 utc_utimes.modtime = utimes->modtime;
10667 # ifdef VMSISH_TIME
10668 /* If input was local; convert to UTC for sys svc */
10670 utc_utimes.actime = _toutc(utimes->actime);
10671 utc_utimes.modtime = _toutc(utimes->modtime);
10674 utc_utimesp = &utc_utimes;
10677 utc_utimesp = NULL;
10680 return utime(file, utc_utimesp);
10682 #else /* __CRTL_VER < 70300000 */
10686 long int bintime[2], len = 2, lowbit, unixtime,
10687 secscale = 10000000; /* seconds --> 100 ns intervals */
10688 unsigned long int chan, iosb[2], retsts;
10689 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10690 struct FAB myfab = cc$rms_fab;
10691 struct NAM mynam = cc$rms_nam;
10692 #if defined (__DECC) && defined (__VAX)
10693 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10694 * at least through VMS V6.1, which causes a type-conversion warning.
10696 # pragma message save
10697 # pragma message disable cvtdiftypes
10699 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10700 struct fibdef myfib;
10701 #if defined (__DECC) && defined (__VAX)
10702 /* This should be right after the declaration of myatr, but due
10703 * to a bug in VAX DEC C, this takes effect a statement early.
10705 # pragma message restore
10707 /* cast ok for read only parameter */
10708 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10709 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10710 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10712 if (file == NULL || *file == '\0') {
10713 SETERRNO(ENOENT, LIB$_INVARG);
10717 /* Convert to VMS format ensuring that it will fit in 255 characters */
10718 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10719 SETERRNO(ENOENT, LIB$_INVARG);
10722 if (utimes != NULL) {
10723 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
10724 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10725 * Since time_t is unsigned long int, and lib$emul takes a signed long int
10726 * as input, we force the sign bit to be clear by shifting unixtime right
10727 * one bit, then multiplying by an extra factor of 2 in lib$emul().
10729 lowbit = (utimes->modtime & 1) ? secscale : 0;
10730 unixtime = (long int) utimes->modtime;
10731 # ifdef VMSISH_TIME
10732 /* If input was UTC; convert to local for sys svc */
10733 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10735 unixtime >>= 1; secscale <<= 1;
10736 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10737 if (!(retsts & 1)) {
10738 SETERRNO(EVMSERR, retsts);
10741 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10742 if (!(retsts & 1)) {
10743 SETERRNO(EVMSERR, retsts);
10748 /* Just get the current time in VMS format directly */
10749 retsts = sys$gettim(bintime);
10750 if (!(retsts & 1)) {
10751 SETERRNO(EVMSERR, retsts);
10756 myfab.fab$l_fna = vmsspec;
10757 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10758 myfab.fab$l_nam = &mynam;
10759 mynam.nam$l_esa = esa;
10760 mynam.nam$b_ess = (unsigned char) sizeof esa;
10761 mynam.nam$l_rsa = rsa;
10762 mynam.nam$b_rss = (unsigned char) sizeof rsa;
10763 if (decc_efs_case_preserve)
10764 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10766 /* Look for the file to be affected, letting RMS parse the file
10767 * specification for us as well. I have set errno using only
10768 * values documented in the utime() man page for VMS POSIX.
10770 retsts = sys$parse(&myfab,0,0);
10771 if (!(retsts & 1)) {
10772 set_vaxc_errno(retsts);
10773 if (retsts == RMS$_PRV) set_errno(EACCES);
10774 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10775 else set_errno(EVMSERR);
10778 retsts = sys$search(&myfab,0,0);
10779 if (!(retsts & 1)) {
10780 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10781 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10782 set_vaxc_errno(retsts);
10783 if (retsts == RMS$_PRV) set_errno(EACCES);
10784 else if (retsts == RMS$_FNF) set_errno(ENOENT);
10785 else set_errno(EVMSERR);
10789 devdsc.dsc$w_length = mynam.nam$b_dev;
10790 /* cast ok for read only parameter */
10791 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10793 retsts = sys$assign(&devdsc,&chan,0,0);
10794 if (!(retsts & 1)) {
10795 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10796 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10797 set_vaxc_errno(retsts);
10798 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
10799 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
10800 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
10801 else set_errno(EVMSERR);
10805 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10806 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10808 memset((void *) &myfib, 0, sizeof myfib);
10809 #if defined(__DECC) || defined(__DECCXX)
10810 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10811 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10812 /* This prevents the revision time of the file being reset to the current
10813 * time as a result of our IO$_MODIFY $QIO. */
10814 myfib.fib$l_acctl = FIB$M_NORECORD;
10816 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10817 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10818 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10820 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10821 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10822 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10823 _ckvmssts(sys$dassgn(chan));
10824 if (retsts & 1) retsts = iosb[0];
10825 if (!(retsts & 1)) {
10826 set_vaxc_errno(retsts);
10827 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10828 else set_errno(EVMSERR);
10834 #endif /* #if __CRTL_VER >= 70300000 */
10836 } /* end of my_utime() */
10840 * flex_stat, flex_lstat, flex_fstat
10841 * basic stat, but gets it right when asked to stat
10842 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10845 #ifndef _USE_STD_STAT
10846 /* encode_dev packs a VMS device name string into an integer to allow
10847 * simple comparisons. This can be used, for example, to check whether two
10848 * files are located on the same device, by comparing their encoded device
10849 * names. Even a string comparison would not do, because stat() reuses the
10850 * device name buffer for each call; so without encode_dev, it would be
10851 * necessary to save the buffer and use strcmp (this would mean a number of
10852 * changes to the standard Perl code, to say nothing of what a Perl script
10853 * would have to do.
10855 * The device lock id, if it exists, should be unique (unless perhaps compared
10856 * with lock ids transferred from other nodes). We have a lock id if the disk is
10857 * mounted cluster-wide, which is when we tend to get long (host-qualified)
10858 * device names. Thus we use the lock id in preference, and only if that isn't
10859 * available, do we try to pack the device name into an integer (flagged by
10860 * the sign bit (LOCKID_MASK) being set).
10862 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10863 * name and its encoded form, but it seems very unlikely that we will find
10864 * two files on different disks that share the same encoded device names,
10865 * and even more remote that they will share the same file id (if the test
10866 * is to check for the same file).
10868 * A better method might be to use sys$device_scan on the first call, and to
10869 * search for the device, returning an index into the cached array.
10870 * The number returned would be more intelligible.
10871 * This is probably not worth it, and anyway would take quite a bit longer
10872 * on the first call.
10874 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
10875 static mydev_t encode_dev (pTHX_ const char *dev)
10878 unsigned long int f;
10883 if (!dev || !dev[0]) return 0;
10887 struct dsc$descriptor_s dev_desc;
10888 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10890 /* For cluster-mounted disks, the disk lock identifier is unique, so we
10891 can try that first. */
10892 dev_desc.dsc$w_length = strlen (dev);
10893 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
10894 dev_desc.dsc$b_class = DSC$K_CLASS_S;
10895 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
10896 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10897 if (!$VMS_STATUS_SUCCESS(status)) {
10899 case SS$_NOSUCHDEV:
10900 SETERRNO(ENODEV, status);
10906 if (lockid) return (lockid & ~LOCKID_MASK);
10910 /* Otherwise we try to encode the device name */
10914 for (q = dev + strlen(dev); q--; q >= dev) {
10919 else if (isalpha (toupper (*q)))
10920 c= toupper (*q) - 'A' + (char)10;
10922 continue; /* Skip '$'s */
10924 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
10926 enc += f * (unsigned long int) c;
10928 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
10930 } /* end of encode_dev() */
10931 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10932 device_no = encode_dev(aTHX_ devname)
10934 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10935 device_no = new_dev_no
10939 is_null_device(name)
10942 if (decc_bug_devnull != 0) {
10943 if (strncmp("/dev/null", name, 9) == 0)
10946 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10947 The underscore prefix, controller letter, and unit number are
10948 independently optional; for our purposes, the colon punctuation
10949 is not. The colon can be trailed by optional directory and/or
10950 filename, but two consecutive colons indicates a nodename rather
10951 than a device. [pr] */
10952 if (*name == '_') ++name;
10953 if (tolower(*name++) != 'n') return 0;
10954 if (tolower(*name++) != 'l') return 0;
10955 if (tolower(*name) == 'a') ++name;
10956 if (*name == '0') ++name;
10957 return (*name++ == ':') && (*name != ':');
10962 Perl_cando_by_name_int
10963 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10965 char usrname[L_cuserid];
10966 struct dsc$descriptor_s usrdsc =
10967 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10968 char *vmsname = NULL, *fileified = NULL;
10969 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10970 unsigned short int retlen, trnlnm_iter_count;
10971 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10972 union prvdef curprv;
10973 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10974 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10975 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10976 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10977 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10979 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10981 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10983 static int profile_context = -1;
10985 if (!fname || !*fname) return FALSE;
10987 /* Make sure we expand logical names, since sys$check_access doesn't */
10988 fileified = PerlMem_malloc(VMS_MAXRSS);
10989 if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
10990 if (!strpbrk(fname,"/]>:")) {
10991 strcpy(fileified,fname);
10992 trnlnm_iter_count = 0;
10993 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
10994 trnlnm_iter_count++;
10995 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11000 vmsname = PerlMem_malloc(VMS_MAXRSS);
11001 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11002 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11003 /* Don't know if already in VMS format, so make sure */
11004 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11005 PerlMem_free(fileified);
11006 PerlMem_free(vmsname);
11011 strcpy(vmsname,fname);
11014 /* sys$check_access needs a file spec, not a directory spec.
11015 * Don't use flex_stat here, as that depends on thread context
11016 * having been initialized, and we may get here during startup.
11019 retlen = namdsc.dsc$w_length = strlen(vmsname);
11020 if (vmsname[retlen-1] == ']'
11021 || vmsname[retlen-1] == '>'
11022 || vmsname[retlen-1] == ':'
11023 || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11025 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11026 PerlMem_free(fileified);
11027 PerlMem_free(vmsname);
11036 retlen = namdsc.dsc$w_length = strlen(fname);
11037 namdsc.dsc$a_pointer = (char *)fname;
11040 case S_IXUSR: case S_IXGRP: case S_IXOTH:
11041 access = ARM$M_EXECUTE;
11042 flags = CHP$M_READ;
11044 case S_IRUSR: case S_IRGRP: case S_IROTH:
11045 access = ARM$M_READ;
11046 flags = CHP$M_READ | CHP$M_USEREADALL;
11048 case S_IWUSR: case S_IWGRP: case S_IWOTH:
11049 access = ARM$M_WRITE;
11050 flags = CHP$M_READ | CHP$M_WRITE;
11052 case S_IDUSR: case S_IDGRP: case S_IDOTH:
11053 access = ARM$M_DELETE;
11054 flags = CHP$M_READ | CHP$M_WRITE;
11057 if (fileified != NULL)
11058 PerlMem_free(fileified);
11059 if (vmsname != NULL)
11060 PerlMem_free(vmsname);
11064 /* Before we call $check_access, create a user profile with the current
11065 * process privs since otherwise it just uses the default privs from the
11066 * UAF and might give false positives or negatives. This only works on
11067 * VMS versions v6.0 and later since that's when sys$create_user_profile
11068 * became available.
11071 /* get current process privs and username */
11072 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11073 _ckvmssts(iosb[0]);
11075 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11077 /* find out the space required for the profile */
11078 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11079 &usrprodsc.dsc$w_length,&profile_context));
11081 /* allocate space for the profile and get it filled in */
11082 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11083 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11084 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11085 &usrprodsc.dsc$w_length,&profile_context));
11087 /* use the profile to check access to the file; free profile & analyze results */
11088 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11089 PerlMem_free(usrprodsc.dsc$a_pointer);
11090 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11094 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11098 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
11099 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11100 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11101 set_vaxc_errno(retsts);
11102 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11103 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11104 else set_errno(ENOENT);
11105 if (fileified != NULL)
11106 PerlMem_free(fileified);
11107 if (vmsname != NULL)
11108 PerlMem_free(vmsname);
11111 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11112 if (fileified != NULL)
11113 PerlMem_free(fileified);
11114 if (vmsname != NULL)
11115 PerlMem_free(vmsname);
11120 if (fileified != NULL)
11121 PerlMem_free(fileified);
11122 if (vmsname != NULL)
11123 PerlMem_free(vmsname);
11124 return FALSE; /* Should never get here */
11128 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
11129 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11130 * subset of the applicable information.
11133 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11135 return cando_by_name_int
11136 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11137 } /* end of cando() */
11141 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11143 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11145 return cando_by_name_int(bit, effective, fname, 0);
11147 } /* end of cando_by_name() */
11151 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11153 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11155 if (!fstat(fd,(stat_t *) statbufp)) {
11157 char *vms_filename;
11158 vms_filename = PerlMem_malloc(VMS_MAXRSS);
11159 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11161 /* Save name for cando by name in VMS format */
11162 cptr = getname(fd, vms_filename, 1);
11164 /* This should not happen, but just in case */
11165 if (cptr == NULL) {
11166 statbufp->st_devnam[0] = 0;
11169 /* Make sure that the saved name fits in 255 characters */
11170 cptr = do_rmsexpand
11172 statbufp->st_devnam,
11175 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11179 statbufp->st_devnam[0] = 0;
11181 PerlMem_free(vms_filename);
11183 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11185 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11187 # ifdef RTL_USES_UTC
11188 # ifdef VMSISH_TIME
11190 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11191 statbufp->st_atime = _toloc(statbufp->st_atime);
11192 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11196 # ifdef VMSISH_TIME
11197 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11201 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11202 statbufp->st_atime = _toutc(statbufp->st_atime);
11203 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11210 } /* end of flex_fstat() */
11213 #if !defined(__VAX) && __CRTL_VER >= 80200000
11221 #define lstat(_x, _y) stat(_x, _y)
11224 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11227 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11229 char fileified[VMS_MAXRSS];
11230 char temp_fspec[VMS_MAXRSS];
11233 int saved_errno, saved_vaxc_errno;
11235 if (!fspec) return retval;
11236 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11237 strcpy(temp_fspec, fspec);
11239 if (decc_bug_devnull != 0) {
11240 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11241 memset(statbufp,0,sizeof *statbufp);
11242 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11243 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11244 statbufp->st_uid = 0x00010001;
11245 statbufp->st_gid = 0x0001;
11246 time((time_t *)&statbufp->st_mtime);
11247 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11252 /* Try for a directory name first. If fspec contains a filename without
11253 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11254 * and sea:[wine.dark]water. exist, we prefer the directory here.
11255 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11256 * not sea:[wine.dark]., if the latter exists. If the intended target is
11257 * the file with null type, specify this by calling flex_stat() with
11258 * a '.' at the end of fspec.
11260 * If we are in Posix filespec mode, accept the filename as is.
11264 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11265 /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11266 * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11268 if (!decc_efs_charset)
11269 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11272 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11273 if (decc_posix_compliant_pathnames == 0) {
11275 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11276 if (lstat_flag == 0)
11277 retval = stat(fileified,(stat_t *) statbufp);
11279 retval = lstat(fileified,(stat_t *) statbufp);
11280 save_spec = fileified;
11283 if (lstat_flag == 0)
11284 retval = stat(temp_fspec,(stat_t *) statbufp);
11286 retval = lstat(temp_fspec,(stat_t *) statbufp);
11287 save_spec = temp_fspec;
11289 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11291 if (lstat_flag == 0)
11292 retval = stat(temp_fspec,(stat_t *) statbufp);
11294 retval = lstat(temp_fspec,(stat_t *) statbufp);
11295 save_spec = temp_fspec;
11299 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11300 /* As you were... */
11301 if (!decc_efs_charset)
11302 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11307 cptr = do_rmsexpand
11308 (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11310 statbufp->st_devnam[0] = 0;
11312 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11314 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11315 # ifdef RTL_USES_UTC
11316 # ifdef VMSISH_TIME
11318 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11319 statbufp->st_atime = _toloc(statbufp->st_atime);
11320 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11324 # ifdef VMSISH_TIME
11325 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11329 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11330 statbufp->st_atime = _toutc(statbufp->st_atime);
11331 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11335 /* If we were successful, leave errno where we found it */
11336 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11339 } /* end of flex_stat_int() */
11342 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11344 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11346 return flex_stat_int(fspec, statbufp, 0);
11350 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11352 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11354 return flex_stat_int(fspec, statbufp, 1);
11359 /*{{{char *my_getlogin()*/
11360 /* VMS cuserid == Unix getlogin, except calling sequence */
11364 static char user[L_cuserid];
11365 return cuserid(user);
11370 /* rmscopy - copy a file using VMS RMS routines
11372 * Copies contents and attributes of spec_in to spec_out, except owner
11373 * and protection information. Name and type of spec_in are used as
11374 * defaults for spec_out. The third parameter specifies whether rmscopy()
11375 * should try to propagate timestamps from the input file to the output file.
11376 * If it is less than 0, no timestamps are preserved. If it is 0, then
11377 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
11378 * propagated to the output file at creation iff the output file specification
11379 * did not contain an explicit name or type, and the revision date is always
11380 * updated at the end of the copy operation. If it is greater than 0, then
11381 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11382 * other than the revision date should be propagated, and bit 1 indicates
11383 * that the revision date should be propagated.
11385 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11387 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11388 * Incorporates, with permission, some code from EZCOPY by Tim Adye
11389 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
11390 * as part of the Perl standard distribution under the terms of the
11391 * GNU General Public License or the Perl Artistic License. Copies
11392 * of each may be found in the Perl standard distribution.
11394 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11396 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11398 char *vmsin, * vmsout, *esa, *esa_out,
11400 unsigned long int i, sts, sts2;
11402 struct FAB fab_in, fab_out;
11403 struct RAB rab_in, rab_out;
11404 rms_setup_nam(nam);
11405 rms_setup_nam(nam_out);
11406 struct XABDAT xabdat;
11407 struct XABFHC xabfhc;
11408 struct XABRDT xabrdt;
11409 struct XABSUM xabsum;
11411 vmsin = PerlMem_malloc(VMS_MAXRSS);
11412 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11413 vmsout = PerlMem_malloc(VMS_MAXRSS);
11414 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11415 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11416 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11417 PerlMem_free(vmsin);
11418 PerlMem_free(vmsout);
11419 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11423 esa = PerlMem_malloc(VMS_MAXRSS);
11424 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11425 fab_in = cc$rms_fab;
11426 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11427 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11428 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11429 fab_in.fab$l_fop = FAB$M_SQO;
11430 rms_bind_fab_nam(fab_in, nam);
11431 fab_in.fab$l_xab = (void *) &xabdat;
11433 rsa = PerlMem_malloc(VMS_MAXRSS);
11434 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11435 rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11436 rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11437 rms_nam_esl(nam) = 0;
11438 rms_nam_rsl(nam) = 0;
11439 rms_nam_esll(nam) = 0;
11440 rms_nam_rsll(nam) = 0;
11441 #ifdef NAM$M_NO_SHORT_UPCASE
11442 if (decc_efs_case_preserve)
11443 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11446 xabdat = cc$rms_xabdat; /* To get creation date */
11447 xabdat.xab$l_nxt = (void *) &xabfhc;
11449 xabfhc = cc$rms_xabfhc; /* To get record length */
11450 xabfhc.xab$l_nxt = (void *) &xabsum;
11452 xabsum = cc$rms_xabsum; /* To get key and area information */
11454 if (!((sts = sys$open(&fab_in)) & 1)) {
11455 PerlMem_free(vmsin);
11456 PerlMem_free(vmsout);
11459 set_vaxc_errno(sts);
11461 case RMS$_FNF: case RMS$_DNF:
11462 set_errno(ENOENT); break;
11464 set_errno(ENOTDIR); break;
11466 set_errno(ENODEV); break;
11468 set_errno(EINVAL); break;
11470 set_errno(EACCES); break;
11472 set_errno(EVMSERR);
11479 fab_out.fab$w_ifi = 0;
11480 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11481 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11482 fab_out.fab$l_fop = FAB$M_SQO;
11483 rms_bind_fab_nam(fab_out, nam_out);
11484 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11485 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11486 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11487 esa_out = PerlMem_malloc(VMS_MAXRSS);
11488 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11489 rms_set_rsa(nam_out, NULL, 0);
11490 rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11492 if (preserve_dates == 0) { /* Act like DCL COPY */
11493 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11494 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
11495 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11496 PerlMem_free(vmsin);
11497 PerlMem_free(vmsout);
11500 PerlMem_free(esa_out);
11501 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11502 set_vaxc_errno(sts);
11505 fab_out.fab$l_xab = (void *) &xabdat;
11506 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11507 preserve_dates = 1;
11509 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
11510 preserve_dates =0; /* bitmask from this point forward */
11512 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11513 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11514 PerlMem_free(vmsin);
11515 PerlMem_free(vmsout);
11518 PerlMem_free(esa_out);
11519 set_vaxc_errno(sts);
11522 set_errno(ENOENT); break;
11524 set_errno(ENOTDIR); break;
11526 set_errno(ENODEV); break;
11528 set_errno(EINVAL); break;
11530 set_errno(EACCES); break;
11532 set_errno(EVMSERR);
11536 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
11537 if (preserve_dates & 2) {
11538 /* sys$close() will process xabrdt, not xabdat */
11539 xabrdt = cc$rms_xabrdt;
11541 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11543 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11544 * is unsigned long[2], while DECC & VAXC use a struct */
11545 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11547 fab_out.fab$l_xab = (void *) &xabrdt;
11550 ubf = PerlMem_malloc(32256);
11551 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11552 rab_in = cc$rms_rab;
11553 rab_in.rab$l_fab = &fab_in;
11554 rab_in.rab$l_rop = RAB$M_BIO;
11555 rab_in.rab$l_ubf = ubf;
11556 rab_in.rab$w_usz = 32256;
11557 if (!((sts = sys$connect(&rab_in)) & 1)) {
11558 sys$close(&fab_in); sys$close(&fab_out);
11559 PerlMem_free(vmsin);
11560 PerlMem_free(vmsout);
11564 PerlMem_free(esa_out);
11565 set_errno(EVMSERR); set_vaxc_errno(sts);
11569 rab_out = cc$rms_rab;
11570 rab_out.rab$l_fab = &fab_out;
11571 rab_out.rab$l_rbf = ubf;
11572 if (!((sts = sys$connect(&rab_out)) & 1)) {
11573 sys$close(&fab_in); sys$close(&fab_out);
11574 PerlMem_free(vmsin);
11575 PerlMem_free(vmsout);
11579 PerlMem_free(esa_out);
11580 set_errno(EVMSERR); set_vaxc_errno(sts);
11584 while ((sts = sys$read(&rab_in))) { /* always true */
11585 if (sts == RMS$_EOF) break;
11586 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11587 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11588 sys$close(&fab_in); sys$close(&fab_out);
11589 PerlMem_free(vmsin);
11590 PerlMem_free(vmsout);
11594 PerlMem_free(esa_out);
11595 set_errno(EVMSERR); set_vaxc_errno(sts);
11601 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
11602 sys$close(&fab_in); sys$close(&fab_out);
11603 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11605 PerlMem_free(vmsin);
11606 PerlMem_free(vmsout);
11610 PerlMem_free(esa_out);
11611 set_errno(EVMSERR); set_vaxc_errno(sts);
11615 PerlMem_free(vmsin);
11616 PerlMem_free(vmsout);
11620 PerlMem_free(esa_out);
11623 } /* end of rmscopy() */
11627 /*** The following glue provides 'hooks' to make some of the routines
11628 * from this file available from Perl. These routines are sufficiently
11629 * basic, and are required sufficiently early in the build process,
11630 * that's it's nice to have them available to miniperl as well as the
11631 * full Perl, so they're set up here instead of in an extension. The
11632 * Perl code which handles importation of these names into a given
11633 * package lives in [.VMS]Filespec.pm in @INC.
11637 rmsexpand_fromperl(pTHX_ CV *cv)
11640 char *fspec, *defspec = NULL, *rslt;
11642 int fs_utf8, dfs_utf8;
11646 if (!items || items > 2)
11647 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11648 fspec = SvPV(ST(0),n_a);
11649 fs_utf8 = SvUTF8(ST(0));
11650 if (!fspec || !*fspec) XSRETURN_UNDEF;
11652 defspec = SvPV(ST(1),n_a);
11653 dfs_utf8 = SvUTF8(ST(1));
11655 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11656 ST(0) = sv_newmortal();
11657 if (rslt != NULL) {
11658 sv_usepvn(ST(0),rslt,strlen(rslt));
11667 vmsify_fromperl(pTHX_ CV *cv)
11674 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11675 utf8_fl = SvUTF8(ST(0));
11676 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11677 ST(0) = sv_newmortal();
11678 if (vmsified != NULL) {
11679 sv_usepvn(ST(0),vmsified,strlen(vmsified));
11688 unixify_fromperl(pTHX_ CV *cv)
11695 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11696 utf8_fl = SvUTF8(ST(0));
11697 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11698 ST(0) = sv_newmortal();
11699 if (unixified != NULL) {
11700 sv_usepvn(ST(0),unixified,strlen(unixified));
11709 fileify_fromperl(pTHX_ CV *cv)
11716 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11717 utf8_fl = SvUTF8(ST(0));
11718 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11719 ST(0) = sv_newmortal();
11720 if (fileified != NULL) {
11721 sv_usepvn(ST(0),fileified,strlen(fileified));
11730 pathify_fromperl(pTHX_ CV *cv)
11737 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11738 utf8_fl = SvUTF8(ST(0));
11739 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11740 ST(0) = sv_newmortal();
11741 if (pathified != NULL) {
11742 sv_usepvn(ST(0),pathified,strlen(pathified));
11751 vmspath_fromperl(pTHX_ CV *cv)
11758 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11759 utf8_fl = SvUTF8(ST(0));
11760 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11761 ST(0) = sv_newmortal();
11762 if (vmspath != NULL) {
11763 sv_usepvn(ST(0),vmspath,strlen(vmspath));
11772 unixpath_fromperl(pTHX_ CV *cv)
11779 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11780 utf8_fl = SvUTF8(ST(0));
11781 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11782 ST(0) = sv_newmortal();
11783 if (unixpath != NULL) {
11784 sv_usepvn(ST(0),unixpath,strlen(unixpath));
11793 candelete_fromperl(pTHX_ CV *cv)
11801 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11803 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11804 Newx(fspec, VMS_MAXRSS, char);
11805 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11806 if (SvTYPE(mysv) == SVt_PVGV) {
11807 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11808 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11816 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11817 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11824 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11830 rmscopy_fromperl(pTHX_ CV *cv)
11833 char *inspec, *outspec, *inp, *outp;
11835 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11836 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11837 unsigned long int sts;
11842 if (items < 2 || items > 3)
11843 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11845 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11846 Newx(inspec, VMS_MAXRSS, char);
11847 if (SvTYPE(mysv) == SVt_PVGV) {
11848 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11849 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11857 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11858 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11864 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11865 Newx(outspec, VMS_MAXRSS, char);
11866 if (SvTYPE(mysv) == SVt_PVGV) {
11867 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11868 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11877 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11878 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11885 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11887 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11893 /* The mod2fname is limited to shorter filenames by design, so it should
11894 * not be modified to support longer EFS pathnames
11897 mod2fname(pTHX_ CV *cv)
11900 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11901 workbuff[NAM$C_MAXRSS*1 + 1];
11902 int total_namelen = 3, counter, num_entries;
11903 /* ODS-5 ups this, but we want to be consistent, so... */
11904 int max_name_len = 39;
11905 AV *in_array = (AV *)SvRV(ST(0));
11907 num_entries = av_len(in_array);
11909 /* All the names start with PL_. */
11910 strcpy(ultimate_name, "PL_");
11912 /* Clean up our working buffer */
11913 Zero(work_name, sizeof(work_name), char);
11915 /* Run through the entries and build up a working name */
11916 for(counter = 0; counter <= num_entries; counter++) {
11917 /* If it's not the first name then tack on a __ */
11919 strcat(work_name, "__");
11921 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11925 /* Check to see if we actually have to bother...*/
11926 if (strlen(work_name) + 3 <= max_name_len) {
11927 strcat(ultimate_name, work_name);
11929 /* It's too darned big, so we need to go strip. We use the same */
11930 /* algorithm as xsubpp does. First, strip out doubled __ */
11931 char *source, *dest, last;
11934 for (source = work_name; *source; source++) {
11935 if (last == *source && last == '_') {
11941 /* Go put it back */
11942 strcpy(work_name, workbuff);
11943 /* Is it still too big? */
11944 if (strlen(work_name) + 3 > max_name_len) {
11945 /* Strip duplicate letters */
11948 for (source = work_name; *source; source++) {
11949 if (last == toupper(*source)) {
11953 last = toupper(*source);
11955 strcpy(work_name, workbuff);
11958 /* Is it *still* too big? */
11959 if (strlen(work_name) + 3 > max_name_len) {
11960 /* Too bad, we truncate */
11961 work_name[max_name_len - 2] = 0;
11963 strcat(ultimate_name, work_name);
11966 /* Okay, return it */
11967 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11972 hushexit_fromperl(pTHX_ CV *cv)
11977 VMSISH_HUSHED = SvTRUE(ST(0));
11979 ST(0) = boolSV(VMSISH_HUSHED);
11985 Perl_vms_start_glob
11986 (pTHX_ SV *tmpglob,
11990 struct vs_str_st *rslt;
11994 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11997 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11998 struct dsc$descriptor_vs rsdsc;
11999 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12000 unsigned long hasver = 0, isunix = 0;
12001 unsigned long int lff_flags = 0;
12004 #ifdef VMS_LONGNAME_SUPPORT
12005 lff_flags = LIB$M_FIL_LONG_NAMES;
12007 /* The Newx macro will not allow me to assign a smaller array
12008 * to the rslt pointer, so we will assign it to the begin char pointer
12009 * and then copy the value into the rslt pointer.
12011 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12012 rslt = (struct vs_str_st *)begin;
12014 rstr = &rslt->str[0];
12015 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12016 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12017 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12018 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12020 Newx(vmsspec, VMS_MAXRSS, char);
12022 /* We could find out if there's an explicit dev/dir or version
12023 by peeking into lib$find_file's internal context at
12024 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12025 but that's unsupported, so I don't want to do it now and
12026 have it bite someone in the future. */
12027 /* Fix-me: vms_split_path() is the only way to do this, the
12028 existing method will fail with many legal EFS or UNIX specifications
12031 cp = SvPV(tmpglob,i);
12034 if (cp[i] == ';') hasver = 1;
12035 if (cp[i] == '.') {
12036 if (sts) hasver = 1;
12039 if (cp[i] == '/') {
12040 hasdir = isunix = 1;
12043 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12048 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12052 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12053 if (!stat_sts && S_ISDIR(st.st_mode)) {
12054 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12055 ok = (wilddsc.dsc$a_pointer != NULL);
12056 /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12060 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12061 ok = (wilddsc.dsc$a_pointer != NULL);
12064 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12066 /* If not extended character set, replace ? with % */
12067 /* With extended character set, ? is a wildcard single character */
12068 if (!decc_efs_case_preserve) {
12069 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12070 if (*cp == '?') *cp = '%';
12073 while (ok && $VMS_STATUS_SUCCESS(sts)) {
12074 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12075 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12077 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12078 &dfltdsc,NULL,&rms_sts,&lff_flags);
12079 if (!$VMS_STATUS_SUCCESS(sts))
12084 /* with varying string, 1st word of buffer contains result length */
12085 rstr[rslt->length] = '\0';
12087 /* Find where all the components are */
12088 v_sts = vms_split_path
12103 /* If no version on input, truncate the version on output */
12104 if (!hasver && (vs_len > 0)) {
12108 /* No version & a null extension on UNIX handling */
12109 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12115 if (!decc_efs_case_preserve) {
12116 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12120 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12124 /* Start with the name */
12127 strcat(begin,"\n");
12128 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12130 if (cxt) (void)lib$find_file_end(&cxt);
12133 /* Be POSIXish: return the input pattern when no matches */
12134 begin = SvPVX(tmpglob);
12135 strcat(begin,"\n");
12136 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12139 if (ok && sts != RMS$_NMF &&
12140 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12143 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12145 PerlIO_close(tmpfp);
12149 PerlIO_rewind(tmpfp);
12150 IoTYPE(io) = IoTYPE_RDONLY;
12151 IoIFP(io) = fp = tmpfp;
12152 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
12163 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
12166 vms_realpath_fromperl(pTHX_ CV *cv)
12169 char *fspec, *rslt_spec, *rslt;
12172 if (!items || items != 1)
12173 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12175 fspec = SvPV(ST(0),n_a);
12176 if (!fspec || !*fspec) XSRETURN_UNDEF;
12178 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12179 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12180 ST(0) = sv_newmortal();
12182 sv_usepvn(ST(0),rslt,strlen(rslt));
12184 Safefree(rslt_spec);
12189 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12190 int do_vms_case_tolerant(void);
12193 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12196 ST(0) = boolSV(do_vms_case_tolerant());
12202 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12203 struct interp_intern *dst)
12205 memcpy(dst,src,sizeof(struct interp_intern));
12209 Perl_sys_intern_clear(pTHX)
12214 Perl_sys_intern_init(pTHX)
12216 unsigned int ix = RAND_MAX;
12221 /* fix me later to track running under GNV */
12222 /* this allows some limited testing */
12223 MY_POSIX_EXIT = decc_filename_unix_report;
12226 MY_INV_RAND_MAX = 1./x;
12230 init_os_extras(void)
12233 char* file = __FILE__;
12234 if (decc_disable_to_vms_logname_translation) {
12235 no_translate_barewords = TRUE;
12237 no_translate_barewords = FALSE;
12240 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12241 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12242 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12243 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12244 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12245 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12246 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12247 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12248 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12249 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12250 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12252 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12254 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12255 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12258 store_pipelocs(aTHX); /* will redo any earlier attempts */
12265 #if __CRTL_VER == 80200000
12266 /* This missed getting in to the DECC SDK for 8.2 */
12267 char *realpath(const char *file_name, char * resolved_name, ...);
12270 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12271 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12272 * The perl fallback routine to provide realpath() is not as efficient
12276 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12278 return realpath(filespec, outbuf);
12282 /* External entry points */
12283 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12284 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12286 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12291 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12292 /* case_tolerant */
12294 /*{{{int do_vms_case_tolerant(void)*/
12295 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12296 * controlled by a process setting.
12298 int do_vms_case_tolerant(void)
12300 return vms_process_case_tolerant;
12303 /* External entry points */
12304 int Perl_vms_case_tolerant(void)
12305 { return do_vms_case_tolerant(); }
12307 int Perl_vms_case_tolerant(void)
12308 { return vms_process_case_tolerant; }
12312 /* Start of DECC RTL Feature handling */
12314 static int sys_trnlnm
12315 (const char * logname,
12319 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12320 const unsigned long attr = LNM$M_CASE_BLIND;
12321 struct dsc$descriptor_s name_dsc;
12323 unsigned short result;
12324 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12327 name_dsc.dsc$w_length = strlen(logname);
12328 name_dsc.dsc$a_pointer = (char *)logname;
12329 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12330 name_dsc.dsc$b_class = DSC$K_CLASS_S;
12332 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12334 if ($VMS_STATUS_SUCCESS(status)) {
12336 /* Null terminate and return the string */
12337 /*--------------------------------------*/
12344 static int sys_crelnm
12345 (const char * logname,
12346 const char * value)
12349 const char * proc_table = "LNM$PROCESS_TABLE";
12350 struct dsc$descriptor_s proc_table_dsc;
12351 struct dsc$descriptor_s logname_dsc;
12352 struct itmlst_3 item_list[2];
12354 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12355 proc_table_dsc.dsc$w_length = strlen(proc_table);
12356 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12357 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12359 logname_dsc.dsc$a_pointer = (char *) logname;
12360 logname_dsc.dsc$w_length = strlen(logname);
12361 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12362 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12364 item_list[0].buflen = strlen(value);
12365 item_list[0].itmcode = LNM$_STRING;
12366 item_list[0].bufadr = (char *)value;
12367 item_list[0].retlen = NULL;
12369 item_list[1].buflen = 0;
12370 item_list[1].itmcode = 0;
12372 ret_val = sys$crelnm
12374 (const struct dsc$descriptor_s *)&proc_table_dsc,
12375 (const struct dsc$descriptor_s *)&logname_dsc,
12377 (const struct item_list_3 *) item_list);
12382 /* C RTL Feature settings */
12384 static int set_features
12385 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
12386 int (* cli_routine)(void), /* Not documented */
12387 void *image_info) /* Not documented */
12394 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12395 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12396 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12397 unsigned long case_perm;
12398 unsigned long case_image;
12401 /* Allow an exception to bring Perl into the VMS debugger */
12402 vms_debug_on_exception = 0;
12403 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12404 if ($VMS_STATUS_SUCCESS(status)) {
12405 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12406 vms_debug_on_exception = 1;
12408 vms_debug_on_exception = 0;
12411 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
12412 vms_vtf7_filenames = 0;
12413 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12414 if ($VMS_STATUS_SUCCESS(status)) {
12415 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12416 vms_vtf7_filenames = 1;
12418 vms_vtf7_filenames = 0;
12421 /* Dectect running under GNV Bash or other UNIX like shell */
12422 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12423 gnv_unix_shell = 0;
12424 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12425 if ($VMS_STATUS_SUCCESS(status)) {
12426 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12427 gnv_unix_shell = 1;
12428 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12429 set_feature_default("DECC$EFS_CHARSET", 1);
12430 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12431 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12432 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12433 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12436 gnv_unix_shell = 0;
12440 /* hacks to see if known bugs are still present for testing */
12442 /* Readdir is returning filenames in VMS syntax always */
12443 decc_bug_readdir_efs1 = 1;
12444 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12445 if ($VMS_STATUS_SUCCESS(status)) {
12446 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12447 decc_bug_readdir_efs1 = 1;
12449 decc_bug_readdir_efs1 = 0;
12452 /* PCP mode requires creating /dev/null special device file */
12453 decc_bug_devnull = 0;
12454 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12455 if ($VMS_STATUS_SUCCESS(status)) {
12456 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12457 decc_bug_devnull = 1;
12459 decc_bug_devnull = 0;
12462 /* fgetname returning a VMS name in UNIX mode */
12463 decc_bug_fgetname = 1;
12464 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12465 if ($VMS_STATUS_SUCCESS(status)) {
12466 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12467 decc_bug_fgetname = 1;
12469 decc_bug_fgetname = 0;
12472 /* UNIX directory names with no paths are broken in a lot of places */
12473 decc_dir_barename = 1;
12474 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12475 if ($VMS_STATUS_SUCCESS(status)) {
12476 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12477 decc_dir_barename = 1;
12479 decc_dir_barename = 0;
12482 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12483 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12485 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12486 if (decc_disable_to_vms_logname_translation < 0)
12487 decc_disable_to_vms_logname_translation = 0;
12490 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12492 decc_efs_case_preserve = decc$feature_get_value(s, 1);
12493 if (decc_efs_case_preserve < 0)
12494 decc_efs_case_preserve = 0;
12497 s = decc$feature_get_index("DECC$EFS_CHARSET");
12499 decc_efs_charset = decc$feature_get_value(s, 1);
12500 if (decc_efs_charset < 0)
12501 decc_efs_charset = 0;
12504 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12506 decc_filename_unix_report = decc$feature_get_value(s, 1);
12507 if (decc_filename_unix_report > 0)
12508 decc_filename_unix_report = 1;
12510 decc_filename_unix_report = 0;
12513 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12515 decc_filename_unix_only = decc$feature_get_value(s, 1);
12516 if (decc_filename_unix_only > 0) {
12517 decc_filename_unix_only = 1;
12520 decc_filename_unix_only = 0;
12524 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12526 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12527 if (decc_filename_unix_no_version < 0)
12528 decc_filename_unix_no_version = 0;
12531 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12533 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12534 if (decc_readdir_dropdotnotype < 0)
12535 decc_readdir_dropdotnotype = 0;
12538 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12539 if ($VMS_STATUS_SUCCESS(status)) {
12540 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12542 dflt = decc$feature_get_value(s, 4);
12544 decc_disable_posix_root = decc$feature_get_value(s, 1);
12545 if (decc_disable_posix_root <= 0) {
12546 decc$feature_set_value(s, 1, 1);
12547 decc_disable_posix_root = 1;
12551 /* Traditionally Perl assumes this is off */
12552 decc_disable_posix_root = 1;
12553 decc$feature_set_value(s, 1, 1);
12558 #if __CRTL_VER >= 80200000
12559 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12561 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12562 if (decc_posix_compliant_pathnames < 0)
12563 decc_posix_compliant_pathnames = 0;
12564 if (decc_posix_compliant_pathnames > 4)
12565 decc_posix_compliant_pathnames = 0;
12570 status = sys_trnlnm
12571 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12572 if ($VMS_STATUS_SUCCESS(status)) {
12573 val_str[0] = _toupper(val_str[0]);
12574 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12575 decc_disable_to_vms_logname_translation = 1;
12580 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12581 if ($VMS_STATUS_SUCCESS(status)) {
12582 val_str[0] = _toupper(val_str[0]);
12583 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12584 decc_efs_case_preserve = 1;
12589 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12590 if ($VMS_STATUS_SUCCESS(status)) {
12591 val_str[0] = _toupper(val_str[0]);
12592 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12593 decc_filename_unix_report = 1;
12596 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12597 if ($VMS_STATUS_SUCCESS(status)) {
12598 val_str[0] = _toupper(val_str[0]);
12599 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12600 decc_filename_unix_only = 1;
12601 decc_filename_unix_report = 1;
12604 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12605 if ($VMS_STATUS_SUCCESS(status)) {
12606 val_str[0] = _toupper(val_str[0]);
12607 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12608 decc_filename_unix_no_version = 1;
12611 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12612 if ($VMS_STATUS_SUCCESS(status)) {
12613 val_str[0] = _toupper(val_str[0]);
12614 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12615 decc_readdir_dropdotnotype = 1;
12620 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12622 /* Report true case tolerance */
12623 /*----------------------------*/
12624 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12625 if (!$VMS_STATUS_SUCCESS(status))
12626 case_perm = PPROP$K_CASE_BLIND;
12627 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12628 if (!$VMS_STATUS_SUCCESS(status))
12629 case_image = PPROP$K_CASE_BLIND;
12630 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12631 (case_image == PPROP$K_CASE_SENSITIVE))
12632 vms_process_case_tolerant = 0;
12637 /* CRTL can be initialized past this point, but not before. */
12638 /* DECC$CRTL_INIT(); */
12645 #pragma extern_model save
12646 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12647 const __align (LONGWORD) int spare[8] = {0};
12649 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
12650 #if __DECC_VER >= 60560002
12651 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
12653 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
12655 #endif /* __DECC */
12657 const long vms_cc_features = (const long)set_features;
12660 ** Force a reference to LIB$INITIALIZE to ensure it
12661 ** exists in the image.
12663 int lib$initialize(void);
12665 #pragma extern_model strict_refdef
12667 int lib_init_ref = (int) lib$initialize;
12670 #pragma extern_model restore