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
87 const struct dsc$descriptor_s * devnam,
88 const struct item_list_3 * itmlst,
90 void * (astadr)(unsigned long),
94 #ifdef USE_VMS_DECTERM
96 /* Routine to create a decterm for use with the Perl debugger */
97 /* No headers, this information was found in the Programming Concepts Manual */
100 (const struct dsc$descriptor_s * display,
101 const struct dsc$descriptor_s * setup_file,
102 const struct dsc$descriptor_s * customization,
103 struct dsc$descriptor_s * result_device_name,
104 unsigned short * result_device_name_length,
107 void * char_change_buffer);
110 #if __CRTL_VER >= 70300000 && !defined(__VAX)
112 static int set_feature_default(const char *name, int value)
117 index = decc$feature_get_index(name);
119 status = decc$feature_set_value(index, 1, value);
120 if (index == -1 || (status == -1)) {
124 status = decc$feature_get_value(index, 1);
125 if (status != value) {
133 /* Older versions of ssdef.h don't have these */
134 #ifndef SS$_INVFILFOROP
135 # define SS$_INVFILFOROP 3930
137 #ifndef SS$_NOSUCHOBJECT
138 # define SS$_NOSUCHOBJECT 2696
141 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
142 #define PERLIO_NOT_STDIO 0
144 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
145 * code below needs to get to the underlying CRTL routines. */
146 #define DONT_MASK_RTL_CALLS
150 /* Anticipating future expansion in lexical warnings . . . */
151 #ifndef WARN_INTERNAL
152 # define WARN_INTERNAL WARN_MISC
155 #ifdef VMS_LONGNAME_SUPPORT
156 #include <libfildef.h>
159 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
160 # define RTL_USES_UTC 1
164 /* gcc's header files don't #define direct access macros
165 * corresponding to VAXC's variant structs */
167 # define uic$v_format uic$r_uic_form.uic$v_format
168 # define uic$v_group uic$r_uic_form.uic$v_group
169 # define uic$v_member uic$r_uic_form.uic$v_member
170 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
171 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
172 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
173 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
176 #if defined(NEED_AN_H_ERRNO)
181 #pragma message disable pragma
182 #pragma member_alignment save
183 #pragma nomember_alignment longword
185 #pragma message disable misalgndmem
188 unsigned short int buflen;
189 unsigned short int itmcode;
191 unsigned short int *retlen;
194 struct filescan_itmlst_2 {
195 unsigned short length;
196 unsigned short itmcode;
201 unsigned short length;
206 #pragma message restore
207 #pragma member_alignment restore
210 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
211 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
212 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
213 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
214 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
215 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
216 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
217 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
218 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
219 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
220 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
222 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
223 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
224 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
225 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
227 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
228 #define PERL_LNM_MAX_ALLOWED_INDEX 127
230 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
231 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
234 #define PERL_LNM_MAX_ITER 10
236 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
237 #if __CRTL_VER >= 70302000 && !defined(__VAX)
238 #define MAX_DCL_SYMBOL (8192)
239 #define MAX_DCL_LINE_LENGTH (4096 - 4)
241 #define MAX_DCL_SYMBOL (1024)
242 #define MAX_DCL_LINE_LENGTH (1024 - 4)
245 static char *__mystrtolower(char *str)
247 if (str) for (; *str; ++str) *str= tolower(*str);
251 static struct dsc$descriptor_s fildevdsc =
252 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
253 static struct dsc$descriptor_s crtlenvdsc =
254 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
255 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
256 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
257 static struct dsc$descriptor_s **env_tables = defenv;
258 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
260 /* True if we shouldn't treat barewords as logicals during directory */
262 static int no_translate_barewords;
265 static int tz_updated = 1;
268 /* DECC Features that may need to affect how Perl interprets
269 * displays filename information
271 static int decc_disable_to_vms_logname_translation = 1;
272 static int decc_disable_posix_root = 1;
273 int decc_efs_case_preserve = 0;
274 static int decc_efs_charset = 0;
275 static int decc_filename_unix_no_version = 0;
276 static int decc_filename_unix_only = 0;
277 int decc_filename_unix_report = 0;
278 int decc_posix_compliant_pathnames = 0;
279 int decc_readdir_dropdotnotype = 0;
280 static int vms_process_case_tolerant = 1;
281 int vms_vtf7_filenames = 0;
282 int gnv_unix_shell = 0;
284 /* bug workarounds if needed */
285 int decc_bug_readdir_efs1 = 0;
286 int decc_bug_devnull = 1;
287 int decc_bug_fgetname = 0;
288 int decc_dir_barename = 0;
290 static int vms_debug_on_exception = 0;
292 /* Is this a UNIX file specification?
293 * No longer a simple check with EFS file specs
294 * For now, not a full check, but need to
295 * handle POSIX ^UP^ specifications
296 * Fixing to handle ^/ cases would require
297 * changes to many other conversion routines.
300 static int is_unix_filespec(const char *path)
306 if (strncmp(path,"\"^UP^",5) != 0) {
307 pch1 = strchr(path, '/');
312 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
313 if (decc_filename_unix_report || decc_filename_unix_only) {
314 if (strcmp(path,".") == 0)
322 /* This routine converts a UCS-2 character to be VTF-7 encoded.
325 static void ucs2_to_vtf7
327 unsigned long ucs2_char,
330 unsigned char * ucs_ptr;
333 ucs_ptr = (unsigned char *)&ucs2_char;
337 hex = (ucs_ptr[1] >> 4) & 0xf;
339 outspec[2] = hex + '0';
341 outspec[2] = (hex - 9) + 'A';
342 hex = ucs_ptr[1] & 0xF;
344 outspec[3] = hex + '0';
346 outspec[3] = (hex - 9) + 'A';
348 hex = (ucs_ptr[0] >> 4) & 0xf;
350 outspec[4] = hex + '0';
352 outspec[4] = (hex - 9) + 'A';
353 hex = ucs_ptr[1] & 0xF;
355 outspec[5] = hex + '0';
357 outspec[5] = (hex - 9) + 'A';
363 /* This handles the conversion of a UNIX extended character set to a ^
364 * escaped VMS character.
365 * in a UNIX file specification.
367 * The output count variable contains the number of characters added
368 * to the output string.
370 * The return value is the number of characters read from the input string
372 static int copy_expand_unix_filename_escape
373 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
381 utf8_flag = *utf8_fl;
385 if (*inspec >= 0x80) {
386 if (utf8_fl && vms_vtf7_filenames) {
387 unsigned long ucs_char;
391 if ((*inspec & 0xE0) == 0xC0) {
393 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
394 if (ucs_char >= 0x80) {
395 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
398 } else if ((*inspec & 0xF0) == 0xE0) {
400 ucs_char = ((inspec[0] & 0xF) << 12) +
401 ((inspec[1] & 0x3f) << 6) +
403 if (ucs_char >= 0x800) {
404 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
408 #if 0 /* I do not see longer sequences supported by OpenVMS */
409 /* Maybe some one can fix this later */
410 } else if ((*inspec & 0xF8) == 0xF0) {
413 } else if ((*inspec & 0xFC) == 0xF8) {
416 } else if ((*inspec & 0xFE) == 0xFC) {
423 /* High bit set, but not a unicode character! */
425 /* Non printing DECMCS or ISO Latin-1 character? */
426 if (*inspec <= 0x9F) {
430 hex = (*inspec >> 4) & 0xF;
432 outspec[1] = hex + '0';
434 outspec[1] = (hex - 9) + 'A';
438 outspec[2] = hex + '0';
440 outspec[2] = (hex - 9) + 'A';
444 } else if (*inspec == 0xA0) {
450 } else if (*inspec == 0xFF) {
462 /* Is this a macro that needs to be passed through?
463 * Macros start with $( and an alpha character, followed
464 * by a string of alpha numeric characters ending with a )
465 * If this does not match, then encode it as ODS-5.
467 if ((inspec[0] == '$') && (inspec[1] == '(')) {
470 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
472 outspec[0] = inspec[0];
473 outspec[1] = inspec[1];
474 outspec[2] = inspec[2];
476 while(isalnum(inspec[tcnt]) ||
477 (inspec[2] == '.') || (inspec[2] == '_')) {
478 outspec[tcnt] = inspec[tcnt];
481 if (inspec[tcnt] == ')') {
482 outspec[tcnt] = inspec[tcnt];
499 if (decc_efs_charset == 0)
526 /* Assume that this is to be escaped */
528 outspec[1] = *inspec;
532 case ' ': /* space */
533 /* Assume that this is to be escaped */
548 /* This handles the expansion of a '^' prefix to the proper character
549 * in a UNIX file specification.
551 * The output count variable contains the number of characters added
552 * to the output string.
554 * The return value is the number of characters read from the input
557 static int copy_expand_vms_filename_escape
558 (char *outspec, const char *inspec, int *output_cnt)
565 if (*inspec == '^') {
569 /* Non trailing dots should just be passed through */
574 case '_': /* space */
580 case 'U': /* Unicode - FIX-ME this is wrong. */
583 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
586 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
587 outspec[0] == c1 & 0xff;
588 outspec[1] == c2 & 0xff;
595 /* Error - do best we can to continue */
605 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
609 scnt = sscanf(inspec, "%2x", &c1);
610 outspec[0] = c1 & 0xff;
633 (const struct dsc$descriptor_s * srcstr,
634 struct filescan_itmlst_2 * valuelist,
635 unsigned long * fldflags,
636 struct dsc$descriptor_s *auxout,
637 unsigned short * retlen);
639 /* vms_split_path - Verify that the input file specification is a
640 * VMS format file specification, and provide pointers to the components of
641 * it. With EFS format filenames, this is virtually the only way to
642 * parse a VMS path specification into components.
644 * If the sum of the components do not add up to the length of the
645 * string, then the passed file specification is probably a UNIX style
648 static int vms_split_path
663 struct dsc$descriptor path_desc;
667 struct filescan_itmlst_2 item_list[9];
668 const int filespec = 0;
669 const int nodespec = 1;
670 const int devspec = 2;
671 const int rootspec = 3;
672 const int dirspec = 4;
673 const int namespec = 5;
674 const int typespec = 6;
675 const int verspec = 7;
677 /* Assume the worst for an easy exit */
692 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
693 path_desc.dsc$w_length = strlen(path);
694 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
695 path_desc.dsc$b_class = DSC$K_CLASS_S;
697 /* Get the total length, if it is shorter than the string passed
698 * then this was probably not a VMS formatted file specification
700 item_list[filespec].itmcode = FSCN$_FILESPEC;
701 item_list[filespec].length = 0;
702 item_list[filespec].component = NULL;
704 /* If the node is present, then it gets considered as part of the
705 * volume name to hopefully make things simple.
707 item_list[nodespec].itmcode = FSCN$_NODE;
708 item_list[nodespec].length = 0;
709 item_list[nodespec].component = NULL;
711 item_list[devspec].itmcode = FSCN$_DEVICE;
712 item_list[devspec].length = 0;
713 item_list[devspec].component = NULL;
715 /* root is a special case, adding it to either the directory or
716 * the device components will probalby complicate things for the
717 * callers of this routine, so leave it separate.
719 item_list[rootspec].itmcode = FSCN$_ROOT;
720 item_list[rootspec].length = 0;
721 item_list[rootspec].component = NULL;
723 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
724 item_list[dirspec].length = 0;
725 item_list[dirspec].component = NULL;
727 item_list[namespec].itmcode = FSCN$_NAME;
728 item_list[namespec].length = 0;
729 item_list[namespec].component = NULL;
731 item_list[typespec].itmcode = FSCN$_TYPE;
732 item_list[typespec].length = 0;
733 item_list[typespec].component = NULL;
735 item_list[verspec].itmcode = FSCN$_VERSION;
736 item_list[verspec].length = 0;
737 item_list[verspec].component = NULL;
739 item_list[8].itmcode = 0;
740 item_list[8].length = 0;
741 item_list[8].component = NULL;
743 status = SYS$FILESCAN
744 ((const struct dsc$descriptor_s *)&path_desc, item_list,
746 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
748 /* If we parsed it successfully these two lengths should be the same */
749 if (path_desc.dsc$w_length != item_list[filespec].length)
752 /* If we got here, then it is a VMS file specification */
755 /* set the volume name */
756 if (item_list[nodespec].length > 0) {
757 *volume = item_list[nodespec].component;
758 *vol_len = item_list[nodespec].length + item_list[devspec].length;
761 *volume = item_list[devspec].component;
762 *vol_len = item_list[devspec].length;
765 *root = item_list[rootspec].component;
766 *root_len = item_list[rootspec].length;
768 *dir = item_list[dirspec].component;
769 *dir_len = item_list[dirspec].length;
771 /* Now fun with versions and EFS file specifications
772 * The parser can not tell the difference when a "." is a version
773 * delimiter or a part of the file specification.
775 if ((decc_efs_charset) &&
776 (item_list[verspec].length > 0) &&
777 (item_list[verspec].component[0] == '.')) {
778 *name = item_list[namespec].component;
779 *name_len = item_list[namespec].length + item_list[typespec].length;
780 *ext = item_list[verspec].component;
781 *ext_len = item_list[verspec].length;
786 *name = item_list[namespec].component;
787 *name_len = item_list[namespec].length;
788 *ext = item_list[typespec].component;
789 *ext_len = item_list[typespec].length;
790 *version = item_list[verspec].component;
791 *ver_len = item_list[verspec].length;
798 * Routine to retrieve the maximum equivalence index for an input
799 * logical name. Some calls to this routine have no knowledge if
800 * the variable is a logical or not. So on error we return a max
803 /*{{{int my_maxidx(const char *lnm) */
805 my_maxidx(const char *lnm)
809 int attr = LNM$M_CASE_BLIND;
810 struct dsc$descriptor lnmdsc;
811 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
814 lnmdsc.dsc$w_length = strlen(lnm);
815 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
816 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
817 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
819 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
820 if ((status & 1) == 0)
827 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
829 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
830 struct dsc$descriptor_s **tabvec, unsigned long int flags)
833 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
834 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
835 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
837 unsigned char acmode;
838 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
839 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
840 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
841 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
843 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
844 #if defined(PERL_IMPLICIT_CONTEXT)
847 aTHX = PERL_GET_INTERP;
853 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
854 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
856 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
857 *cp2 = _toupper(*cp1);
858 if (cp1 - lnm > LNM$C_NAMLENGTH) {
859 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
863 lnmdsc.dsc$w_length = cp1 - lnm;
864 lnmdsc.dsc$a_pointer = uplnm;
865 uplnm[lnmdsc.dsc$w_length] = '\0';
866 secure = flags & PERL__TRNENV_SECURE;
867 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
868 if (!tabvec || !*tabvec) tabvec = env_tables;
870 for (curtab = 0; tabvec[curtab]; curtab++) {
871 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
872 if (!ivenv && !secure) {
877 Perl_warn(aTHX_ "Can't read CRTL environ\n");
880 retsts = SS$_NOLOGNAM;
881 for (i = 0; environ[i]; i++) {
882 if ((eq = strchr(environ[i],'=')) &&
883 lnmdsc.dsc$w_length == (eq - environ[i]) &&
884 !strncmp(environ[i],uplnm,eq - environ[i])) {
886 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
887 if (!eqvlen) continue;
892 if (retsts != SS$_NOLOGNAM) break;
895 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
896 !str$case_blind_compare(&tmpdsc,&clisym)) {
897 if (!ivsym && !secure) {
898 unsigned short int deflen = LNM$C_NAMLENGTH;
899 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
900 /* dynamic dsc to accomodate possible long value */
901 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
902 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
904 if (eqvlen > MAX_DCL_SYMBOL) {
905 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
906 eqvlen = MAX_DCL_SYMBOL;
907 /* Special hack--we might be called before the interpreter's */
908 /* fully initialized, in which case either thr or PL_curcop */
909 /* might be bogus. We have to check, since ckWARN needs them */
910 /* both to be valid if running threaded */
911 if (ckWARN(WARN_MISC)) {
912 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
915 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
917 _ckvmssts(lib$sfree1_dd(&eqvdsc));
918 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
919 if (retsts == LIB$_NOSUCHSYM) continue;
924 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
925 midx = my_maxidx(lnm);
926 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
927 lnmlst[1].bufadr = cp2;
929 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
930 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
931 if (retsts == SS$_NOLOGNAM) break;
932 /* PPFs have a prefix */
935 *((int *)uplnm) == *((int *)"SYS$") &&
937 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
938 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
939 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
940 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
941 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
942 memmove(eqv,eqv+4,eqvlen-4);
948 if ((retsts == SS$_IVLOGNAM) ||
949 (retsts == SS$_NOLOGNAM)) { continue; }
952 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
953 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
954 if (retsts == SS$_NOLOGNAM) continue;
957 eqvlen = strlen(eqv);
961 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
962 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
963 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
964 retsts == SS$_NOLOGNAM) {
965 set_errno(EINVAL); set_vaxc_errno(retsts);
967 else _ckvmssts(retsts);
969 } /* end of vmstrnenv */
972 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
973 /* Define as a function so we can access statics. */
974 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
976 return vmstrnenv(lnm,eqv,idx,fildev,
977 #ifdef SECURE_INTERNAL_GETENV
978 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
987 * Note: Uses Perl temp to store result so char * can be returned to
988 * caller; this pointer will be invalidated at next Perl statement
990 * We define this as a function rather than a macro in terms of my_getenv_len()
991 * so that it'll work when PL_curinterp is undefined (and we therefore can't
994 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
996 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
999 static char *__my_getenv_eqv = NULL;
1000 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1001 unsigned long int idx = 0;
1002 int trnsuccess, success, secure, saverr, savvmserr;
1006 midx = my_maxidx(lnm) + 1;
1008 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1009 /* Set up a temporary buffer for the return value; Perl will
1010 * clean it up at the next statement transition */
1011 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1012 if (!tmpsv) return NULL;
1016 /* Assume no interpreter ==> single thread */
1017 if (__my_getenv_eqv != NULL) {
1018 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1021 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1023 eqv = __my_getenv_eqv;
1026 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1027 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1029 getcwd(eqv,LNM$C_NAMLENGTH);
1033 /* Get rid of "000000/ in rooted filespecs */
1036 zeros = strstr(eqv, "/000000/");
1037 if (zeros != NULL) {
1039 mlen = len - (zeros - eqv) - 7;
1040 memmove(zeros, &zeros[7], mlen);
1048 /* Impose security constraints only if tainting */
1050 /* Impose security constraints only if tainting */
1051 secure = PL_curinterp ? PL_tainting : will_taint;
1052 saverr = errno; savvmserr = vaxc$errno;
1059 #ifdef SECURE_INTERNAL_GETENV
1060 secure ? PERL__TRNENV_SECURE : 0
1066 /* For the getenv interface we combine all the equivalence names
1067 * of a search list logical into one value to acquire a maximum
1068 * value length of 255*128 (assuming %ENV is using logicals).
1070 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1072 /* If the name contains a semicolon-delimited index, parse it
1073 * off and make sure we only retrieve the equivalence name for
1075 if ((cp2 = strchr(lnm,';')) != NULL) {
1077 uplnm[cp2-lnm] = '\0';
1078 idx = strtoul(cp2+1,NULL,0);
1080 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1083 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1085 /* Discard NOLOGNAM on internal calls since we're often looking
1086 * for an optional name, and this "error" often shows up as the
1087 * (bogus) exit status for a die() call later on. */
1088 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1089 return success ? eqv : Nullch;
1092 } /* end of my_getenv() */
1096 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1098 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1102 unsigned long idx = 0;
1104 static char *__my_getenv_len_eqv = NULL;
1105 int secure, saverr, savvmserr;
1108 midx = my_maxidx(lnm) + 1;
1110 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1111 /* Set up a temporary buffer for the return value; Perl will
1112 * clean it up at the next statement transition */
1113 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1114 if (!tmpsv) return NULL;
1118 /* Assume no interpreter ==> single thread */
1119 if (__my_getenv_len_eqv != NULL) {
1120 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1123 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1125 buf = __my_getenv_len_eqv;
1128 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1129 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1132 getcwd(buf,LNM$C_NAMLENGTH);
1135 /* Get rid of "000000/ in rooted filespecs */
1137 zeros = strstr(buf, "/000000/");
1138 if (zeros != NULL) {
1140 mlen = *len - (zeros - buf) - 7;
1141 memmove(zeros, &zeros[7], mlen);
1150 /* Impose security constraints only if tainting */
1151 secure = PL_curinterp ? PL_tainting : will_taint;
1152 saverr = errno; savvmserr = vaxc$errno;
1159 #ifdef SECURE_INTERNAL_GETENV
1160 secure ? PERL__TRNENV_SECURE : 0
1166 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1168 if ((cp2 = strchr(lnm,';')) != NULL) {
1170 buf[cp2-lnm] = '\0';
1171 idx = strtoul(cp2+1,NULL,0);
1173 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1176 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1178 /* Get rid of "000000/ in rooted filespecs */
1181 zeros = strstr(buf, "/000000/");
1182 if (zeros != NULL) {
1184 mlen = *len - (zeros - buf) - 7;
1185 memmove(zeros, &zeros[7], mlen);
1191 /* Discard NOLOGNAM on internal calls since we're often looking
1192 * for an optional name, and this "error" often shows up as the
1193 * (bogus) exit status for a die() call later on. */
1194 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1195 return *len ? buf : Nullch;
1198 } /* end of my_getenv_len() */
1201 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1203 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1205 /*{{{ void prime_env_iter() */
1207 prime_env_iter(void)
1208 /* Fill the %ENV associative array with all logical names we can
1209 * find, in preparation for iterating over it.
1212 static int primed = 0;
1213 HV *seenhv = NULL, *envhv;
1215 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1216 unsigned short int chan;
1217 #ifndef CLI$M_TRUSTED
1218 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1220 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1221 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1223 bool have_sym = FALSE, have_lnm = FALSE;
1224 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1225 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1226 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1227 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1228 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1229 #if defined(PERL_IMPLICIT_CONTEXT)
1232 #if defined(USE_ITHREADS)
1233 static perl_mutex primenv_mutex;
1234 MUTEX_INIT(&primenv_mutex);
1237 #if defined(PERL_IMPLICIT_CONTEXT)
1238 /* We jump through these hoops because we can be called at */
1239 /* platform-specific initialization time, which is before anything is */
1240 /* set up--we can't even do a plain dTHX since that relies on the */
1241 /* interpreter structure to be initialized */
1243 aTHX = PERL_GET_INTERP;
1249 if (primed || !PL_envgv) return;
1250 MUTEX_LOCK(&primenv_mutex);
1251 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1252 envhv = GvHVn(PL_envgv);
1253 /* Perform a dummy fetch as an lval to insure that the hash table is
1254 * set up. Otherwise, the hv_store() will turn into a nullop. */
1255 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1257 for (i = 0; env_tables[i]; i++) {
1258 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1259 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1260 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1262 if (have_sym || have_lnm) {
1263 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1264 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1265 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1266 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1269 for (i--; i >= 0; i--) {
1270 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1273 for (j = 0; environ[j]; j++) {
1274 if (!(start = strchr(environ[j],'='))) {
1275 if (ckWARN(WARN_INTERNAL))
1276 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1280 sv = newSVpv(start,0);
1282 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1287 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1288 !str$case_blind_compare(&tmpdsc,&clisym)) {
1289 strcpy(cmd,"Show Symbol/Global *");
1290 cmddsc.dsc$w_length = 20;
1291 if (env_tables[i]->dsc$w_length == 12 &&
1292 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1293 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1294 flags = defflags | CLI$M_NOLOGNAM;
1297 strcpy(cmd,"Show Logical *");
1298 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1299 strcat(cmd," /Table=");
1300 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1301 cmddsc.dsc$w_length = strlen(cmd);
1303 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1304 flags = defflags | CLI$M_NOCLISYM;
1307 /* Create a new subprocess to execute each command, to exclude the
1308 * remote possibility that someone could subvert a mbx or file used
1309 * to write multiple commands to a single subprocess.
1312 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1313 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1314 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1315 defflags &= ~CLI$M_TRUSTED;
1316 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1318 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1319 if (seenhv) SvREFCNT_dec(seenhv);
1322 char *cp1, *cp2, *key;
1323 unsigned long int sts, iosb[2], retlen, keylen;
1326 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1327 if (sts & 1) sts = iosb[0] & 0xffff;
1328 if (sts == SS$_ENDOFFILE) {
1330 while (substs == 0) { sys$hiber(); wakect++;}
1331 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1336 retlen = iosb[0] >> 16;
1337 if (!retlen) continue; /* blank line */
1339 if (iosb[1] != subpid) {
1341 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1345 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1346 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1348 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1349 if (*cp1 == '(' || /* Logical name table name */
1350 *cp1 == '=' /* Next eqv of searchlist */) continue;
1351 if (*cp1 == '"') cp1++;
1352 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1353 key = cp1; keylen = cp2 - cp1;
1354 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1355 while (*cp2 && *cp2 != '=') cp2++;
1356 while (*cp2 && *cp2 == '=') cp2++;
1357 while (*cp2 && *cp2 == ' ') cp2++;
1358 if (*cp2 == '"') { /* String translation; may embed "" */
1359 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1360 cp2++; cp1--; /* Skip "" surrounding translation */
1362 else { /* Numeric translation */
1363 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1364 cp1--; /* stop on last non-space char */
1366 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1367 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1370 PERL_HASH(hash,key,keylen);
1372 if (cp1 == cp2 && *cp2 == '.') {
1373 /* A single dot usually means an unprintable character, such as a null
1374 * to indicate a zero-length value. Get the actual value to make sure.
1376 char lnm[LNM$C_NAMLENGTH+1];
1377 char eqv[MAX_DCL_SYMBOL+1];
1379 strncpy(lnm, key, keylen);
1380 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1381 sv = newSVpvn(eqv, strlen(eqv));
1384 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1388 hv_store(envhv,key,keylen,sv,hash);
1389 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1391 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1392 /* get the PPFs for this process, not the subprocess */
1393 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1394 char eqv[LNM$C_NAMLENGTH+1];
1396 for (i = 0; ppfs[i]; i++) {
1397 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1398 sv = newSVpv(eqv,trnlen);
1400 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1405 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1406 if (buf) Safefree(buf);
1407 if (seenhv) SvREFCNT_dec(seenhv);
1408 MUTEX_UNLOCK(&primenv_mutex);
1411 } /* end of prime_env_iter */
1415 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1416 /* Define or delete an element in the same "environment" as
1417 * vmstrnenv(). If an element is to be deleted, it's removed from
1418 * the first place it's found. If it's to be set, it's set in the
1419 * place designated by the first element of the table vector.
1420 * Like setenv() returns 0 for success, non-zero on error.
1423 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1426 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1427 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1429 unsigned long int retsts, usermode = PSL$C_USER;
1430 struct itmlst_3 *ile, *ilist;
1431 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1432 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1433 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1434 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1435 $DESCRIPTOR(local,"_LOCAL");
1438 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1439 return SS$_IVLOGNAM;
1442 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1443 *cp2 = _toupper(*cp1);
1444 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1445 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1446 return SS$_IVLOGNAM;
1449 lnmdsc.dsc$w_length = cp1 - lnm;
1450 if (!tabvec || !*tabvec) tabvec = env_tables;
1452 if (!eqv) { /* we're deleting n element */
1453 for (curtab = 0; tabvec[curtab]; curtab++) {
1454 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1456 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1457 if ((cp1 = strchr(environ[i],'=')) &&
1458 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1459 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1461 return setenv(lnm,"",1) ? vaxc$errno : 0;
1464 ivenv = 1; retsts = SS$_NOLOGNAM;
1466 if (ckWARN(WARN_INTERNAL))
1467 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1468 ivenv = 1; retsts = SS$_NOSUCHPGM;
1474 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1475 !str$case_blind_compare(&tmpdsc,&clisym)) {
1476 unsigned int symtype;
1477 if (tabvec[curtab]->dsc$w_length == 12 &&
1478 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1479 !str$case_blind_compare(&tmpdsc,&local))
1480 symtype = LIB$K_CLI_LOCAL_SYM;
1481 else symtype = LIB$K_CLI_GLOBAL_SYM;
1482 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1483 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1484 if (retsts == LIB$_NOSUCHSYM) continue;
1488 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1489 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1490 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1491 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1492 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1496 else { /* we're defining a value */
1497 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1499 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1501 if (ckWARN(WARN_INTERNAL))
1502 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1503 retsts = SS$_NOSUCHPGM;
1507 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1508 eqvdsc.dsc$w_length = strlen(eqv);
1509 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1510 !str$case_blind_compare(&tmpdsc,&clisym)) {
1511 unsigned int symtype;
1512 if (tabvec[0]->dsc$w_length == 12 &&
1513 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1514 !str$case_blind_compare(&tmpdsc,&local))
1515 symtype = LIB$K_CLI_LOCAL_SYM;
1516 else symtype = LIB$K_CLI_GLOBAL_SYM;
1517 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1520 if (!*eqv) eqvdsc.dsc$w_length = 1;
1521 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1523 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1524 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1525 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1526 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1527 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1528 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1531 Newx(ilist,nseg+1,struct itmlst_3);
1534 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1537 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1539 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1540 ile->itmcode = LNM$_STRING;
1542 if ((j+1) == nseg) {
1543 ile->buflen = strlen(c);
1544 /* in case we are truncating one that's too long */
1545 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1548 ile->buflen = LNM$C_NAMLENGTH;
1552 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1556 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1561 if (!(retsts & 1)) {
1563 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1564 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1565 set_errno(EVMSERR); break;
1566 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1567 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1568 set_errno(EINVAL); break;
1570 set_errno(EACCES); break;
1575 set_vaxc_errno(retsts);
1576 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1579 /* We reset error values on success because Perl does an hv_fetch()
1580 * before each hv_store(), and if the thing we're setting didn't
1581 * previously exist, we've got a leftover error message. (Of course,
1582 * this fails in the face of
1583 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1584 * in that the error reported in $! isn't spurious,
1585 * but it's right more often than not.)
1587 set_errno(0); set_vaxc_errno(retsts);
1591 } /* end of vmssetenv() */
1594 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1595 /* This has to be a function since there's a prototype for it in proto.h */
1597 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1600 int len = strlen(lnm);
1604 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1605 if (!strcmp(uplnm,"DEFAULT")) {
1606 if (eqv && *eqv) my_chdir(eqv);
1610 #ifndef RTL_USES_UTC
1611 if (len == 6 || len == 2) {
1614 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1616 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1617 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1621 (void) vmssetenv(lnm,eqv,NULL);
1625 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1627 * sets a user-mode logical in the process logical name table
1628 * used for redirection of sys$error
1631 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1633 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1634 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1635 unsigned long int iss, attr = LNM$M_CONFINE;
1636 unsigned char acmode = PSL$C_USER;
1637 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1639 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1640 d_name.dsc$w_length = strlen(name);
1642 lnmlst[0].buflen = strlen(eqv);
1643 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1645 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1646 if (!(iss&1)) lib$signal(iss);
1651 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1652 /* my_crypt - VMS password hashing
1653 * my_crypt() provides an interface compatible with the Unix crypt()
1654 * C library function, and uses sys$hash_password() to perform VMS
1655 * password hashing. The quadword hashed password value is returned
1656 * as a NUL-terminated 8 character string. my_crypt() does not change
1657 * the case of its string arguments; in order to match the behavior
1658 * of LOGINOUT et al., alphabetic characters in both arguments must
1659 * be upcased by the caller.
1661 * - fix me to call ACM services when available
1664 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1666 # ifndef UAI$C_PREFERRED_ALGORITHM
1667 # define UAI$C_PREFERRED_ALGORITHM 127
1669 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1670 unsigned short int salt = 0;
1671 unsigned long int sts;
1673 unsigned short int dsc$w_length;
1674 unsigned char dsc$b_type;
1675 unsigned char dsc$b_class;
1676 const char * dsc$a_pointer;
1677 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1678 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1679 struct itmlst_3 uailst[3] = {
1680 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1681 { sizeof salt, UAI$_SALT, &salt, 0},
1682 { 0, 0, NULL, NULL}};
1683 static char hash[9];
1685 usrdsc.dsc$w_length = strlen(usrname);
1686 usrdsc.dsc$a_pointer = usrname;
1687 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1689 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1693 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1698 set_vaxc_errno(sts);
1699 if (sts != RMS$_RNF) return NULL;
1702 txtdsc.dsc$w_length = strlen(textpasswd);
1703 txtdsc.dsc$a_pointer = textpasswd;
1704 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1705 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1708 return (char *) hash;
1710 } /* end of my_crypt() */
1714 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1715 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1716 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1718 /* fixup barenames that are directories for internal use.
1719 * There have been problems with the consistent handling of UNIX
1720 * style directory names when routines are presented with a name that
1721 * has no directory delimitors at all. So this routine will eventually
1724 static char * fixup_bare_dirnames(const char * name)
1726 if (decc_disable_to_vms_logname_translation) {
1733 * A little hack to get around a bug in some implemenation of remove()
1734 * that do not know how to delete a directory
1736 * Delete any file to which user has control access, regardless of whether
1737 * delete access is explicitly allowed.
1738 * Limitations: User must have write access to parent directory.
1739 * Does not block signals or ASTs; if interrupted in midstream
1740 * may leave file with an altered ACL.
1743 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1745 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1747 char *vmsname, *rspec;
1749 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1750 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1751 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1753 unsigned char myace$b_length;
1754 unsigned char myace$b_type;
1755 unsigned short int myace$w_flags;
1756 unsigned long int myace$l_access;
1757 unsigned long int myace$l_ident;
1758 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1759 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1760 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1762 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1763 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1764 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1765 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1766 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1767 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1769 /* Expand the input spec using RMS, since the CRTL remove() and
1770 * system services won't do this by themselves, so we may miss
1771 * a file "hiding" behind a logical name or search list. */
1772 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1773 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1775 if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1776 PerlMem_free(vmsname);
1780 if (decc_posix_compliant_pathnames) {
1781 /* In POSIX mode, we prefer to remove the UNIX name */
1783 remove_name = (char *)name;
1786 rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1787 if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1788 if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1789 PerlMem_free(rspec);
1790 PerlMem_free(vmsname);
1793 PerlMem_free(vmsname);
1794 remove_name = rspec;
1797 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1799 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1800 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1801 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1803 do_pathify_dirspec(name, remove_name, 0, NULL);
1804 if (!rmdir(remove_name)) {
1806 PerlMem_free(remove_name);
1807 PerlMem_free(rspec);
1808 return 0; /* Can we just get rid of it? */
1812 if (!rmdir(remove_name)) {
1813 PerlMem_free(rspec);
1814 return 0; /* Can we just get rid of it? */
1820 if (!remove(remove_name)) {
1821 PerlMem_free(rspec);
1822 return 0; /* Can we just get rid of it? */
1825 /* If not, can changing protections help? */
1826 if (vaxc$errno != RMS$_PRV) {
1827 PerlMem_free(rspec);
1831 /* No, so we get our own UIC to use as a rights identifier,
1832 * and the insert an ACE at the head of the ACL which allows us
1833 * to delete the file.
1835 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1836 fildsc.dsc$w_length = strlen(rspec);
1837 fildsc.dsc$a_pointer = rspec;
1839 newace.myace$l_ident = oldace.myace$l_ident;
1840 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1842 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1843 set_errno(ENOENT); break;
1845 set_errno(ENOTDIR); break;
1847 set_errno(ENODEV); break;
1848 case RMS$_SYN: case SS$_INVFILFOROP:
1849 set_errno(EINVAL); break;
1851 set_errno(EACCES); break;
1855 set_vaxc_errno(aclsts);
1856 PerlMem_free(rspec);
1859 /* Grab any existing ACEs with this identifier in case we fail */
1860 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1861 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1862 || fndsts == SS$_NOMOREACE ) {
1863 /* Add the new ACE . . . */
1864 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1867 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1869 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1870 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1871 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1873 do_pathify_dirspec(name, remove_name, 0, NULL);
1874 rmsts = rmdir(remove_name);
1875 PerlMem_free(remove_name);
1878 rmsts = rmdir(remove_name);
1882 rmsts = remove(remove_name);
1884 /* We blew it - dir with files in it, no write priv for
1885 * parent directory, etc. Put things back the way they were. */
1886 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1889 addlst[0].bufadr = &oldace;
1890 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1897 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1898 /* We just deleted it, so of course it's not there. Some versions of
1899 * VMS seem to return success on the unlock operation anyhow (after all
1900 * the unlock is successful), but others don't.
1902 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1903 if (aclsts & 1) aclsts = fndsts;
1904 if (!(aclsts & 1)) {
1906 set_vaxc_errno(aclsts);
1907 PerlMem_free(rspec);
1911 PerlMem_free(rspec);
1914 } /* end of kill_file() */
1918 /*{{{int do_rmdir(char *name)*/
1920 Perl_do_rmdir(pTHX_ const char *name)
1922 char dirfile[NAM$C_MAXRSS+1];
1926 if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1927 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1928 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1931 } /* end of do_rmdir */
1935 * Delete any file to which user has control access, regardless of whether
1936 * delete access is explicitly allowed.
1937 * Limitations: User must have write access to parent directory.
1938 * Does not block signals or ASTs; if interrupted in midstream
1939 * may leave file with an altered ACL.
1942 /*{{{int kill_file(char *name)*/
1944 Perl_kill_file(pTHX_ const char *name)
1946 char rspec[NAM$C_MAXRSS+1];
1948 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1949 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1950 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1952 unsigned char myace$b_length;
1953 unsigned char myace$b_type;
1954 unsigned short int myace$w_flags;
1955 unsigned long int myace$l_access;
1956 unsigned long int myace$l_ident;
1957 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1958 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1959 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1961 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1962 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1963 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1964 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1965 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1966 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1968 /* Expand the input spec using RMS, since the CRTL remove() and
1969 * system services won't do this by themselves, so we may miss
1970 * a file "hiding" behind a logical name or search list. */
1971 tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1972 if (tspec == NULL) return -1;
1973 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1974 /* If not, can changing protections help? */
1975 if (vaxc$errno != RMS$_PRV) return -1;
1977 /* No, so we get our own UIC to use as a rights identifier,
1978 * and the insert an ACE at the head of the ACL which allows us
1979 * to delete the file.
1981 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1982 fildsc.dsc$w_length = strlen(rspec);
1983 fildsc.dsc$a_pointer = rspec;
1985 newace.myace$l_ident = oldace.myace$l_ident;
1986 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1988 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1989 set_errno(ENOENT); break;
1991 set_errno(ENOTDIR); break;
1993 set_errno(ENODEV); break;
1994 case RMS$_SYN: case SS$_INVFILFOROP:
1995 set_errno(EINVAL); break;
1997 set_errno(EACCES); break;
2001 set_vaxc_errno(aclsts);
2004 /* Grab any existing ACEs with this identifier in case we fail */
2005 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2006 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2007 || fndsts == SS$_NOMOREACE ) {
2008 /* Add the new ACE . . . */
2009 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2011 if ((rmsts = remove(name))) {
2012 /* We blew it - dir with files in it, no write priv for
2013 * parent directory, etc. Put things back the way they were. */
2014 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2017 addlst[0].bufadr = &oldace;
2018 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2025 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2026 /* We just deleted it, so of course it's not there. Some versions of
2027 * VMS seem to return success on the unlock operation anyhow (after all
2028 * the unlock is successful), but others don't.
2030 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2031 if (aclsts & 1) aclsts = fndsts;
2032 if (!(aclsts & 1)) {
2034 set_vaxc_errno(aclsts);
2040 } /* end of kill_file() */
2044 /*{{{int my_mkdir(char *,Mode_t)*/
2046 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2048 STRLEN dirlen = strlen(dir);
2050 /* zero length string sometimes gives ACCVIO */
2051 if (dirlen == 0) return -1;
2053 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2054 * null file name/type. However, it's commonplace under Unix,
2055 * so we'll allow it for a gain in portability.
2057 if (dir[dirlen-1] == '/') {
2058 char *newdir = savepvn(dir,dirlen-1);
2059 int ret = mkdir(newdir,mode);
2063 else return mkdir(dir,mode);
2064 } /* end of my_mkdir */
2067 /*{{{int my_chdir(char *)*/
2069 Perl_my_chdir(pTHX_ const char *dir)
2071 STRLEN dirlen = strlen(dir);
2073 /* zero length string sometimes gives ACCVIO */
2074 if (dirlen == 0) return -1;
2077 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2078 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2079 * so that existing scripts do not need to be changed.
2082 while ((dirlen > 0) && (*dir1 == ' ')) {
2087 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2089 * null file name/type. However, it's commonplace under Unix,
2090 * so we'll allow it for a gain in portability.
2092 * - Preview- '/' will be valid soon on VMS
2094 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2095 char *newdir = savepvn(dir1,dirlen-1);
2096 int ret = chdir(newdir);
2100 else return chdir(dir1);
2101 } /* end of my_chdir */
2105 /*{{{FILE *my_tmpfile()*/
2112 if ((fp = tmpfile())) return fp;
2114 cp = PerlMem_malloc(L_tmpnam+24);
2115 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2117 if (decc_filename_unix_only == 0)
2118 strcpy(cp,"Sys$Scratch:");
2121 tmpnam(cp+strlen(cp));
2122 strcat(cp,".Perltmp");
2123 fp = fopen(cp,"w+","fop=dlt");
2130 #ifndef HOMEGROWN_POSIX_SIGNALS
2132 * The C RTL's sigaction fails to check for invalid signal numbers so we
2133 * help it out a bit. The docs are correct, but the actual routine doesn't
2134 * do what the docs say it will.
2136 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2138 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2139 struct sigaction* oact)
2141 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2142 SETERRNO(EINVAL, SS$_INVARG);
2145 return sigaction(sig, act, oact);
2150 #ifdef KILL_BY_SIGPRC
2151 #include <errnodef.h>
2153 /* We implement our own kill() using the undocumented system service
2154 sys$sigprc for one of two reasons:
2156 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2157 target process to do a sys$exit, which usually can't be handled
2158 gracefully...certainly not by Perl and the %SIG{} mechanism.
2160 2.) If the kill() in the CRTL can't be called from a signal
2161 handler without disappearing into the ether, i.e., the signal
2162 it purportedly sends is never trapped. Still true as of VMS 7.3.
2164 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2165 in the target process rather than calling sys$exit.
2167 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2168 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2169 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2170 with condition codes C$_SIG0+nsig*8, catching the exception on the
2171 target process and resignaling with appropriate arguments.
2173 But we don't have that VMS 7.0+ exception handler, so if you
2174 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2176 Also note that SIGTERM is listed in the docs as being "unimplemented",
2177 yet always seems to be signaled with a VMS condition code of 4 (and
2178 correctly handled for that code). So we hardwire it in.
2180 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2181 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2182 than signalling with an unrecognized (and unhandled by CRTL) code.
2185 #define _MY_SIG_MAX 28
2188 Perl_sig_to_vmscondition_int(int sig)
2190 static unsigned int sig_code[_MY_SIG_MAX+1] =
2193 SS$_HANGUP, /* 1 SIGHUP */
2194 SS$_CONTROLC, /* 2 SIGINT */
2195 SS$_CONTROLY, /* 3 SIGQUIT */
2196 SS$_RADRMOD, /* 4 SIGILL */
2197 SS$_BREAK, /* 5 SIGTRAP */
2198 SS$_OPCCUS, /* 6 SIGABRT */
2199 SS$_COMPAT, /* 7 SIGEMT */
2201 SS$_FLTOVF, /* 8 SIGFPE VAX */
2203 SS$_HPARITH, /* 8 SIGFPE AXP */
2205 SS$_ABORT, /* 9 SIGKILL */
2206 SS$_ACCVIO, /* 10 SIGBUS */
2207 SS$_ACCVIO, /* 11 SIGSEGV */
2208 SS$_BADPARAM, /* 12 SIGSYS */
2209 SS$_NOMBX, /* 13 SIGPIPE */
2210 SS$_ASTFLT, /* 14 SIGALRM */
2227 #if __VMS_VER >= 60200000
2228 static int initted = 0;
2231 sig_code[16] = C$_SIGUSR1;
2232 sig_code[17] = C$_SIGUSR2;
2233 #if __CRTL_VER >= 70000000
2234 sig_code[20] = C$_SIGCHLD;
2236 #if __CRTL_VER >= 70300000
2237 sig_code[28] = C$_SIGWINCH;
2242 if (sig < _SIG_MIN) return 0;
2243 if (sig > _MY_SIG_MAX) return 0;
2244 return sig_code[sig];
2248 Perl_sig_to_vmscondition(int sig)
2251 if (vms_debug_on_exception != 0)
2252 lib$signal(SS$_DEBUG);
2254 return Perl_sig_to_vmscondition_int(sig);
2259 Perl_my_kill(int pid, int sig)
2264 int sys$sigprc(unsigned int *pidadr,
2265 struct dsc$descriptor_s *prcname,
2268 /* sig 0 means validate the PID */
2269 /*------------------------------*/
2271 const unsigned long int jpicode = JPI$_PID;
2274 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2275 if ($VMS_STATUS_SUCCESS(status))
2278 case SS$_NOSUCHNODE:
2279 case SS$_UNREACHABLE:
2293 code = Perl_sig_to_vmscondition_int(sig);
2296 SETERRNO(EINVAL, SS$_BADPARAM);
2300 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2301 * signals are to be sent to multiple processes.
2302 * pid = 0 - all processes in group except ones that the system exempts
2303 * pid = -1 - all processes except ones that the system exempts
2304 * pid = -n - all processes in group (abs(n)) except ...
2305 * For now, just report as not supported.
2309 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2313 iss = sys$sigprc((unsigned int *)&pid,0,code);
2314 if (iss&1) return 0;
2318 set_errno(EPERM); break;
2320 case SS$_NOSUCHNODE:
2321 case SS$_UNREACHABLE:
2322 set_errno(ESRCH); break;
2324 set_errno(ENOMEM); break;
2329 set_vaxc_errno(iss);
2335 /* Routine to convert a VMS status code to a UNIX status code.
2336 ** More tricky than it appears because of conflicting conventions with
2339 ** VMS status codes are a bit mask, with the least significant bit set for
2342 ** Special UNIX status of EVMSERR indicates that no translation is currently
2343 ** available, and programs should check the VMS status code.
2345 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2349 #ifndef C_FACILITY_NO
2350 #define C_FACILITY_NO 0x350000
2353 #define DCL_IVVERB 0x38090
2356 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2364 /* Assume the best or the worst */
2365 if (vms_status & STS$M_SUCCESS)
2368 unix_status = EVMSERR;
2370 msg_status = vms_status & ~STS$M_CONTROL;
2372 facility = vms_status & STS$M_FAC_NO;
2373 fac_sp = vms_status & STS$M_FAC_SP;
2374 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2376 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2382 unix_status = EFAULT;
2384 case SS$_DEVOFFLINE:
2385 unix_status = EBUSY;
2388 unix_status = ENOTCONN;
2396 case SS$_INVFILFOROP:
2400 unix_status = EINVAL;
2402 case SS$_UNSUPPORTED:
2403 unix_status = ENOTSUP;
2408 unix_status = EACCES;
2410 case SS$_DEVICEFULL:
2411 unix_status = ENOSPC;
2414 unix_status = ENODEV;
2416 case SS$_NOSUCHFILE:
2417 case SS$_NOSUCHOBJECT:
2418 unix_status = ENOENT;
2420 case SS$_ABORT: /* Fatal case */
2421 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2422 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2423 unix_status = EINTR;
2426 unix_status = E2BIG;
2429 unix_status = ENOMEM;
2432 unix_status = EPERM;
2434 case SS$_NOSUCHNODE:
2435 case SS$_UNREACHABLE:
2436 unix_status = ESRCH;
2439 unix_status = ECHILD;
2442 if ((facility == 0) && (msg_no < 8)) {
2443 /* These are not real VMS status codes so assume that they are
2444 ** already UNIX status codes
2446 unix_status = msg_no;
2452 /* Translate a POSIX exit code to a UNIX exit code */
2453 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2454 unix_status = (msg_no & 0x07F8) >> 3;
2458 /* Documented traditional behavior for handling VMS child exits */
2459 /*--------------------------------------------------------------*/
2460 if (child_flag != 0) {
2462 /* Success / Informational return 0 */
2463 /*----------------------------------*/
2464 if (msg_no & STS$K_SUCCESS)
2467 /* Warning returns 1 */
2468 /*-------------------*/
2469 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2472 /* Everything else pass through the severity bits */
2473 /*------------------------------------------------*/
2474 return (msg_no & STS$M_SEVERITY);
2477 /* Normal VMS status to ERRNO mapping attempt */
2478 /*--------------------------------------------*/
2479 switch(msg_status) {
2480 /* case RMS$_EOF: */ /* End of File */
2481 case RMS$_FNF: /* File Not Found */
2482 case RMS$_DNF: /* Dir Not Found */
2483 unix_status = ENOENT;
2485 case RMS$_RNF: /* Record Not Found */
2486 unix_status = ESRCH;
2489 unix_status = ENOTDIR;
2492 unix_status = ENODEV;
2497 unix_status = EBADF;
2500 unix_status = EEXIST;
2504 case LIB$_INVSTRDES:
2506 case LIB$_NOSUCHSYM:
2507 case LIB$_INVSYMNAM:
2509 unix_status = EINVAL;
2515 unix_status = E2BIG;
2517 case RMS$_PRV: /* No privilege */
2518 case RMS$_ACC: /* ACP file access failed */
2519 case RMS$_WLK: /* Device write locked */
2520 unix_status = EACCES;
2522 /* case RMS$_NMF: */ /* No more files */
2530 /* Try to guess at what VMS error status should go with a UNIX errno
2531 * value. This is hard to do as there could be many possible VMS
2532 * error statuses that caused the errno value to be set.
2535 int Perl_unix_status_to_vms(int unix_status)
2537 int test_unix_status;
2539 /* Trivial cases first */
2540 /*---------------------*/
2541 if (unix_status == EVMSERR)
2544 /* Is vaxc$errno sane? */
2545 /*---------------------*/
2546 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2547 if (test_unix_status == unix_status)
2550 /* If way out of range, must be VMS code already */
2551 /*-----------------------------------------------*/
2552 if (unix_status > EVMSERR)
2555 /* If out of range, punt */
2556 /*-----------------------*/
2557 if (unix_status > __ERRNO_MAX)
2561 /* Ok, now we have to do it the hard way. */
2562 /*----------------------------------------*/
2563 switch(unix_status) {
2564 case 0: return SS$_NORMAL;
2565 case EPERM: return SS$_NOPRIV;
2566 case ENOENT: return SS$_NOSUCHOBJECT;
2567 case ESRCH: return SS$_UNREACHABLE;
2568 case EINTR: return SS$_ABORT;
2571 case E2BIG: return SS$_BUFFEROVF;
2573 case EBADF: return RMS$_IFI;
2574 case ECHILD: return SS$_NONEXPR;
2576 case ENOMEM: return SS$_INSFMEM;
2577 case EACCES: return SS$_FILACCERR;
2578 case EFAULT: return SS$_ACCVIO;
2580 case EBUSY: return SS$_DEVOFFLINE;
2581 case EEXIST: return RMS$_FEX;
2583 case ENODEV: return SS$_NOSUCHDEV;
2584 case ENOTDIR: return RMS$_DIR;
2586 case EINVAL: return SS$_INVARG;
2592 case ENOSPC: return SS$_DEVICEFULL;
2593 case ESPIPE: return LIB$_INVARG;
2598 case ERANGE: return LIB$_INVARG;
2599 /* case EWOULDBLOCK */
2600 /* case EINPROGRESS */
2603 /* case EDESTADDRREQ */
2605 /* case EPROTOTYPE */
2606 /* case ENOPROTOOPT */
2607 /* case EPROTONOSUPPORT */
2608 /* case ESOCKTNOSUPPORT */
2609 /* case EOPNOTSUPP */
2610 /* case EPFNOSUPPORT */
2611 /* case EAFNOSUPPORT */
2612 /* case EADDRINUSE */
2613 /* case EADDRNOTAVAIL */
2615 /* case ENETUNREACH */
2616 /* case ENETRESET */
2617 /* case ECONNABORTED */
2618 /* case ECONNRESET */
2621 case ENOTCONN: return SS$_CLEARED;
2622 /* case ESHUTDOWN */
2623 /* case ETOOMANYREFS */
2624 /* case ETIMEDOUT */
2625 /* case ECONNREFUSED */
2627 /* case ENAMETOOLONG */
2628 /* case EHOSTDOWN */
2629 /* case EHOSTUNREACH */
2630 /* case ENOTEMPTY */
2642 /* case ECANCELED */
2646 return SS$_UNSUPPORTED;
2652 /* case EABANDONED */
2654 return SS$_ABORT; /* punt */
2657 return SS$_ABORT; /* Should not get here */
2661 /* default piping mailbox size */
2662 #define PERL_BUFSIZ 512
2666 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2668 unsigned long int mbxbufsiz;
2669 static unsigned long int syssize = 0;
2670 unsigned long int dviitm = DVI$_DEVNAM;
2671 char csize[LNM$C_NAMLENGTH+1];
2675 unsigned long syiitm = SYI$_MAXBUF;
2677 * Get the SYSGEN parameter MAXBUF
2679 * If the logical 'PERL_MBX_SIZE' is defined
2680 * use the value of the logical instead of PERL_BUFSIZ, but
2681 * keep the size between 128 and MAXBUF.
2684 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2687 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2688 mbxbufsiz = atoi(csize);
2690 mbxbufsiz = PERL_BUFSIZ;
2692 if (mbxbufsiz < 128) mbxbufsiz = 128;
2693 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2695 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2697 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2698 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2700 } /* end of create_mbx() */
2703 /*{{{ my_popen and my_pclose*/
2705 typedef struct _iosb IOSB;
2706 typedef struct _iosb* pIOSB;
2707 typedef struct _pipe Pipe;
2708 typedef struct _pipe* pPipe;
2709 typedef struct pipe_details Info;
2710 typedef struct pipe_details* pInfo;
2711 typedef struct _srqp RQE;
2712 typedef struct _srqp* pRQE;
2713 typedef struct _tochildbuf CBuf;
2714 typedef struct _tochildbuf* pCBuf;
2717 unsigned short status;
2718 unsigned short count;
2719 unsigned long dvispec;
2722 #pragma member_alignment save
2723 #pragma nomember_alignment quadword
2724 struct _srqp { /* VMS self-relative queue entry */
2725 unsigned long qptr[2];
2727 #pragma member_alignment restore
2728 static RQE RQE_ZERO = {0,0};
2730 struct _tochildbuf {
2733 unsigned short size;
2741 unsigned short chan_in;
2742 unsigned short chan_out;
2744 unsigned int bufsize;
2756 #if defined(PERL_IMPLICIT_CONTEXT)
2757 void *thx; /* Either a thread or an interpreter */
2758 /* pointer, depending on how we're built */
2766 PerlIO *fp; /* file pointer to pipe mailbox */
2767 int useFILE; /* using stdio, not perlio */
2768 int pid; /* PID of subprocess */
2769 int mode; /* == 'r' if pipe open for reading */
2770 int done; /* subprocess has completed */
2771 int waiting; /* waiting for completion/closure */
2772 int closing; /* my_pclose is closing this pipe */
2773 unsigned long completion; /* termination status of subprocess */
2774 pPipe in; /* pipe in to sub */
2775 pPipe out; /* pipe out of sub */
2776 pPipe err; /* pipe of sub's sys$error */
2777 int in_done; /* true when in pipe finished */
2780 unsigned short xchan; /* channel to debug xterm */
2781 unsigned short xchan_valid; /* channel is assigned */
2784 struct exit_control_block
2786 struct exit_control_block *flink;
2787 unsigned long int (*exit_routine)();
2788 unsigned long int arg_count;
2789 unsigned long int *status_address;
2790 unsigned long int exit_status;
2793 typedef struct _closed_pipes Xpipe;
2794 typedef struct _closed_pipes* pXpipe;
2796 struct _closed_pipes {
2797 int pid; /* PID of subprocess */
2798 unsigned long completion; /* termination status of subprocess */
2800 #define NKEEPCLOSED 50
2801 static Xpipe closed_list[NKEEPCLOSED];
2802 static int closed_index = 0;
2803 static int closed_num = 0;
2805 #define RETRY_DELAY "0 ::0.20"
2806 #define MAX_RETRY 50
2808 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2809 static unsigned long mypid;
2810 static unsigned long delaytime[2];
2812 static pInfo open_pipes = NULL;
2813 static $DESCRIPTOR(nl_desc, "NL:");
2815 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2819 static unsigned long int
2820 pipe_exit_routine(pTHX)
2823 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2824 int sts, did_stuff, need_eof, j;
2827 flush any pending i/o
2833 PerlIO_flush(info->fp); /* first, flush data */
2835 fflush((FILE *)info->fp);
2841 next we try sending an EOF...ignore if doesn't work, make sure we
2849 _ckvmssts_noperl(sys$setast(0));
2850 if (info->in && !info->in->shut_on_empty) {
2851 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2856 _ckvmssts_noperl(sys$setast(1));
2860 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2862 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2867 _ckvmssts_noperl(sys$setast(0));
2868 if (info->waiting && info->done)
2870 nwait += info->waiting;
2871 _ckvmssts_noperl(sys$setast(1));
2881 _ckvmssts_noperl(sys$setast(0));
2882 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2883 sts = sys$forcex(&info->pid,0,&abort);
2884 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2887 _ckvmssts_noperl(sys$setast(1));
2891 /* again, wait for effect */
2893 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2898 _ckvmssts_noperl(sys$setast(0));
2899 if (info->waiting && info->done)
2901 nwait += info->waiting;
2902 _ckvmssts_noperl(sys$setast(1));
2911 _ckvmssts_noperl(sys$setast(0));
2912 if (!info->done) { /* We tried to be nice . . . */
2913 sts = sys$delprc(&info->pid,0);
2914 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2915 info->done = 1; /* sys$delprc is as done as we're going to get. */
2917 _ckvmssts_noperl(sys$setast(1));
2922 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2923 else if (!(sts & 1)) retsts = sts;
2928 static struct exit_control_block pipe_exitblock =
2929 {(struct exit_control_block *) 0,
2930 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2932 static void pipe_mbxtofd_ast(pPipe p);
2933 static void pipe_tochild1_ast(pPipe p);
2934 static void pipe_tochild2_ast(pPipe p);
2937 popen_completion_ast(pInfo info)
2939 pInfo i = open_pipes;
2944 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2945 closed_list[closed_index].pid = info->pid;
2946 closed_list[closed_index].completion = info->completion;
2948 if (closed_index == NKEEPCLOSED)
2953 if (i == info) break;
2956 if (!i) return; /* unlinked, probably freed too */
2961 Writing to subprocess ...
2962 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2964 chan_out may be waiting for "done" flag, or hung waiting
2965 for i/o completion to child...cancel the i/o. This will
2966 put it into "snarf mode" (done but no EOF yet) that discards
2969 Output from subprocess (stdout, stderr) needs to be flushed and
2970 shut down. We try sending an EOF, but if the mbx is full the pipe
2971 routine should still catch the "shut_on_empty" flag, telling it to
2972 use immediate-style reads so that "mbx empty" -> EOF.
2976 if (info->in && !info->in_done) { /* only for mode=w */
2977 if (info->in->shut_on_empty && info->in->need_wake) {
2978 info->in->need_wake = FALSE;
2979 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2981 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2985 if (info->out && !info->out_done) { /* were we also piping output? */
2986 info->out->shut_on_empty = TRUE;
2987 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2988 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2989 _ckvmssts_noperl(iss);
2992 if (info->err && !info->err_done) { /* we were piping stderr */
2993 info->err->shut_on_empty = TRUE;
2994 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2995 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2996 _ckvmssts_noperl(iss);
2998 _ckvmssts_noperl(sys$setef(pipe_ef));
3002 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3003 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3006 we actually differ from vmstrnenv since we use this to
3007 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3008 are pointing to the same thing
3011 static unsigned short
3012 popen_translate(pTHX_ char *logical, char *result)
3015 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3016 $DESCRIPTOR(d_log,"");
3018 unsigned short length;
3019 unsigned short code;
3021 unsigned short *retlenaddr;
3023 unsigned short l, ifi;
3025 d_log.dsc$a_pointer = logical;
3026 d_log.dsc$w_length = strlen(logical);
3028 itmlst[0].code = LNM$_STRING;
3029 itmlst[0].length = 255;
3030 itmlst[0].buffer_addr = result;
3031 itmlst[0].retlenaddr = &l;
3034 itmlst[1].length = 0;
3035 itmlst[1].buffer_addr = 0;
3036 itmlst[1].retlenaddr = 0;
3038 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3039 if (iss == SS$_NOLOGNAM) {
3043 if (!(iss&1)) lib$signal(iss);
3046 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3047 strip it off and return the ifi, if any
3050 if (result[0] == 0x1b && result[1] == 0x00) {
3051 memmove(&ifi,result+2,2);
3052 strcpy(result,result+4);
3054 return ifi; /* this is the RMS internal file id */
3057 static void pipe_infromchild_ast(pPipe p);
3060 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3061 inside an AST routine without worrying about reentrancy and which Perl
3062 memory allocator is being used.
3064 We read data and queue up the buffers, then spit them out one at a
3065 time to the output mailbox when the output mailbox is ready for one.
3068 #define INITIAL_TOCHILDQUEUE 2
3071 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3075 char mbx1[64], mbx2[64];
3076 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3077 DSC$K_CLASS_S, mbx1},
3078 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3079 DSC$K_CLASS_S, mbx2};
3080 unsigned int dviitm = DVI$_DEVBUFSIZ;
3084 _ckvmssts(lib$get_vm(&n, &p));
3086 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3087 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3088 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3091 p->shut_on_empty = FALSE;
3092 p->need_wake = FALSE;
3095 p->iosb.status = SS$_NORMAL;
3096 p->iosb2.status = SS$_NORMAL;
3102 #ifdef PERL_IMPLICIT_CONTEXT
3106 n = sizeof(CBuf) + p->bufsize;
3108 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3109 _ckvmssts(lib$get_vm(&n, &b));
3110 b->buf = (char *) b + sizeof(CBuf);
3111 _ckvmssts(lib$insqhi(b, &p->free));
3114 pipe_tochild2_ast(p);
3115 pipe_tochild1_ast(p);
3121 /* reads the MBX Perl is writing, and queues */
3124 pipe_tochild1_ast(pPipe p)
3127 int iss = p->iosb.status;
3128 int eof = (iss == SS$_ENDOFFILE);
3130 #ifdef PERL_IMPLICIT_CONTEXT
3136 p->shut_on_empty = TRUE;
3138 _ckvmssts(sys$dassgn(p->chan_in));
3144 b->size = p->iosb.count;
3145 _ckvmssts(sts = lib$insqhi(b, &p->wait));
3147 p->need_wake = FALSE;
3148 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3151 p->retry = 1; /* initial call */
3154 if (eof) { /* flush the free queue, return when done */
3155 int n = sizeof(CBuf) + p->bufsize;
3157 iss = lib$remqti(&p->free, &b);
3158 if (iss == LIB$_QUEWASEMP) return;
3160 _ckvmssts(lib$free_vm(&n, &b));
3164 iss = lib$remqti(&p->free, &b);
3165 if (iss == LIB$_QUEWASEMP) {
3166 int n = sizeof(CBuf) + p->bufsize;
3167 _ckvmssts(lib$get_vm(&n, &b));
3168 b->buf = (char *) b + sizeof(CBuf);
3174 iss = sys$qio(0,p->chan_in,
3175 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3177 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3178 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3183 /* writes queued buffers to output, waits for each to complete before
3187 pipe_tochild2_ast(pPipe p)
3190 int iss = p->iosb2.status;
3191 int n = sizeof(CBuf) + p->bufsize;
3192 int done = (p->info && p->info->done) ||
3193 iss == SS$_CANCEL || iss == SS$_ABORT;
3194 #if defined(PERL_IMPLICIT_CONTEXT)
3199 if (p->type) { /* type=1 has old buffer, dispose */
3200 if (p->shut_on_empty) {
3201 _ckvmssts(lib$free_vm(&n, &b));
3203 _ckvmssts(lib$insqhi(b, &p->free));
3208 iss = lib$remqti(&p->wait, &b);
3209 if (iss == LIB$_QUEWASEMP) {
3210 if (p->shut_on_empty) {
3212 _ckvmssts(sys$dassgn(p->chan_out));
3213 *p->pipe_done = TRUE;
3214 _ckvmssts(sys$setef(pipe_ef));
3216 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3217 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3221 p->need_wake = TRUE;
3231 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3232 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3234 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3235 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3244 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3247 char mbx1[64], mbx2[64];
3248 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3249 DSC$K_CLASS_S, mbx1},
3250 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3251 DSC$K_CLASS_S, mbx2};
3252 unsigned int dviitm = DVI$_DEVBUFSIZ;
3254 int n = sizeof(Pipe);
3255 _ckvmssts(lib$get_vm(&n, &p));
3256 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3257 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3259 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3260 n = p->bufsize * sizeof(char);
3261 _ckvmssts(lib$get_vm(&n, &p->buf));
3262 p->shut_on_empty = FALSE;
3265 p->iosb.status = SS$_NORMAL;
3266 #if defined(PERL_IMPLICIT_CONTEXT)
3269 pipe_infromchild_ast(p);
3277 pipe_infromchild_ast(pPipe p)
3279 int iss = p->iosb.status;
3280 int eof = (iss == SS$_ENDOFFILE);
3281 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3282 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3283 #if defined(PERL_IMPLICIT_CONTEXT)
3287 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3288 _ckvmssts(sys$dassgn(p->chan_out));
3293 input shutdown if EOF from self (done or shut_on_empty)
3294 output shutdown if closing flag set (my_pclose)
3295 send data/eof from child or eof from self
3296 otherwise, re-read (snarf of data from child)
3301 if (myeof && p->chan_in) { /* input shutdown */
3302 _ckvmssts(sys$dassgn(p->chan_in));
3307 if (myeof || kideof) { /* pass EOF to parent */
3308 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3309 pipe_infromchild_ast, p,
3312 } else if (eof) { /* eat EOF --- fall through to read*/
3314 } else { /* transmit data */
3315 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3316 pipe_infromchild_ast,p,
3317 p->buf, p->iosb.count, 0, 0, 0, 0));
3323 /* everything shut? flag as done */
3325 if (!p->chan_in && !p->chan_out) {
3326 *p->pipe_done = TRUE;
3327 _ckvmssts(sys$setef(pipe_ef));
3331 /* write completed (or read, if snarfing from child)
3332 if still have input active,
3333 queue read...immediate mode if shut_on_empty so we get EOF if empty
3335 check if Perl reading, generate EOFs as needed
3341 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3342 pipe_infromchild_ast,p,
3343 p->buf, p->bufsize, 0, 0, 0, 0);
3344 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3346 } else { /* send EOFs for extra reads */
3347 p->iosb.status = SS$_ENDOFFILE;
3348 p->iosb.dvispec = 0;
3349 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3351 pipe_infromchild_ast, p, 0, 0, 0, 0));
3357 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3361 unsigned long dviitm = DVI$_DEVBUFSIZ;
3363 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3364 DSC$K_CLASS_S, mbx};
3365 int n = sizeof(Pipe);
3367 /* things like terminals and mbx's don't need this filter */
3368 if (fd && fstat(fd,&s) == 0) {
3369 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3371 unsigned short dev_len;
3372 struct dsc$descriptor_s d_dev;
3374 struct item_list_3 items[3];
3376 unsigned short dvi_iosb[4];
3378 cptr = getname(fd, out, 1);
3379 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3380 d_dev.dsc$a_pointer = out;
3381 d_dev.dsc$w_length = strlen(out);
3382 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3383 d_dev.dsc$b_class = DSC$K_CLASS_S;
3386 items[0].code = DVI$_DEVCHAR;
3387 items[0].bufadr = &devchar;
3388 items[0].retadr = NULL;
3390 items[1].code = DVI$_FULLDEVNAM;
3391 items[1].bufadr = device;
3392 items[1].retadr = &dev_len;
3396 status = sys$getdviw
3397 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3399 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3400 device[dev_len] = 0;
3402 if (!(devchar & DEV$M_DIR)) {
3403 strcpy(out, device);
3409 _ckvmssts(lib$get_vm(&n, &p));
3410 p->fd_out = dup(fd);
3411 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3412 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3413 n = (p->bufsize+1) * sizeof(char);
3414 _ckvmssts(lib$get_vm(&n, &p->buf));
3415 p->shut_on_empty = FALSE;
3420 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3421 pipe_mbxtofd_ast, p,
3422 p->buf, p->bufsize, 0, 0, 0, 0));
3428 pipe_mbxtofd_ast(pPipe p)
3430 int iss = p->iosb.status;
3431 int done = p->info->done;
3433 int eof = (iss == SS$_ENDOFFILE);
3434 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3435 int err = !(iss&1) && !eof;
3436 #if defined(PERL_IMPLICIT_CONTEXT)
3440 if (done && myeof) { /* end piping */
3442 sys$dassgn(p->chan_in);
3443 *p->pipe_done = TRUE;
3444 _ckvmssts(sys$setef(pipe_ef));
3448 if (!err && !eof) { /* good data to send to file */
3449 p->buf[p->iosb.count] = '\n';
3450 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3453 if (p->retry < MAX_RETRY) {
3454 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3464 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3465 pipe_mbxtofd_ast, p,
3466 p->buf, p->bufsize, 0, 0, 0, 0);
3467 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3472 typedef struct _pipeloc PLOC;
3473 typedef struct _pipeloc* pPLOC;
3477 char dir[NAM$C_MAXRSS+1];
3479 static pPLOC head_PLOC = 0;
3482 free_pipelocs(pTHX_ void *head)
3485 pPLOC *pHead = (pPLOC *)head;
3497 store_pipelocs(pTHX)
3506 char temp[NAM$C_MAXRSS+1];
3510 free_pipelocs(aTHX_ &head_PLOC);
3512 /* the . directory from @INC comes last */
3514 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3515 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3516 p->next = head_PLOC;
3518 strcpy(p->dir,"./");
3520 /* get the directory from $^X */
3522 unixdir = PerlMem_malloc(VMS_MAXRSS);
3523 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3525 #ifdef PERL_IMPLICIT_CONTEXT
3526 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3528 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3530 strcpy(temp, PL_origargv[0]);
3531 x = strrchr(temp,']');
3533 x = strrchr(temp,'>');
3535 /* It could be a UNIX path */
3536 x = strrchr(temp,'/');
3542 /* Got a bare name, so use default directory */
3547 if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3548 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3549 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3550 p->next = head_PLOC;
3552 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3553 p->dir[NAM$C_MAXRSS] = '\0';
3557 /* reverse order of @INC entries, skip "." since entered above */
3559 #ifdef PERL_IMPLICIT_CONTEXT
3562 if (PL_incgv) av = GvAVn(PL_incgv);
3564 for (i = 0; av && i <= AvFILL(av); i++) {
3565 dirsv = *av_fetch(av,i,TRUE);
3567 if (SvROK(dirsv)) continue;
3568 dir = SvPVx(dirsv,n_a);
3569 if (strcmp(dir,".") == 0) continue;
3570 if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3573 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3574 p->next = head_PLOC;
3576 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3577 p->dir[NAM$C_MAXRSS] = '\0';
3580 /* most likely spot (ARCHLIB) put first in the list */
3583 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3584 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3585 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3586 p->next = head_PLOC;
3588 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3589 p->dir[NAM$C_MAXRSS] = '\0';
3592 PerlMem_free(unixdir);
3596 Perl_cando_by_name_int
3597 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3598 #if !defined(PERL_IMPLICIT_CONTEXT)
3599 #define cando_by_name_int Perl_cando_by_name_int
3601 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3607 static int vmspipe_file_status = 0;
3608 static char vmspipe_file[NAM$C_MAXRSS+1];
3610 /* already found? Check and use ... need read+execute permission */
3612 if (vmspipe_file_status == 1) {
3613 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3614 && cando_by_name_int
3615 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3616 return vmspipe_file;
3618 vmspipe_file_status = 0;
3621 /* scan through stored @INC, $^X */
3623 if (vmspipe_file_status == 0) {
3624 char file[NAM$C_MAXRSS+1];
3625 pPLOC p = head_PLOC;
3630 strcpy(file, p->dir);
3631 dirlen = strlen(file);
3632 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3633 file[NAM$C_MAXRSS] = '\0';
3636 exp_res = do_rmsexpand
3637 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3638 if (!exp_res) continue;
3640 if (cando_by_name_int
3641 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3642 && cando_by_name_int
3643 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3644 vmspipe_file_status = 1;
3645 return vmspipe_file;
3648 vmspipe_file_status = -1; /* failed, use tempfiles */
3655 vmspipe_tempfile(pTHX)
3657 char file[NAM$C_MAXRSS+1];
3659 static int index = 0;
3663 /* create a tempfile */
3665 /* we can't go from W, shr=get to R, shr=get without
3666 an intermediate vulnerable state, so don't bother trying...
3668 and lib$spawn doesn't shr=put, so have to close the write
3670 So... match up the creation date/time and the FID to
3671 make sure we're dealing with the same file
3676 if (!decc_filename_unix_only) {
3677 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3678 fp = fopen(file,"w");
3680 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3681 fp = fopen(file,"w");
3683 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3684 fp = fopen(file,"w");
3689 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3690 fp = fopen(file,"w");
3692 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3693 fp = fopen(file,"w");
3695 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3696 fp = fopen(file,"w");
3700 if (!fp) return 0; /* we're hosed */
3702 fprintf(fp,"$! 'f$verify(0)'\n");
3703 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3704 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3705 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3706 fprintf(fp,"$ perl_on = \"set noon\"\n");
3707 fprintf(fp,"$ perl_exit = \"exit\"\n");
3708 fprintf(fp,"$ perl_del = \"delete\"\n");
3709 fprintf(fp,"$ pif = \"if\"\n");
3710 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3711 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3712 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3713 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3714 fprintf(fp,"$! --- build command line to get max possible length\n");
3715 fprintf(fp,"$c=perl_popen_cmd0\n");
3716 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3717 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3718 fprintf(fp,"$x=perl_popen_cmd3\n");
3719 fprintf(fp,"$c=c+x\n");
3720 fprintf(fp,"$ perl_on\n");
3721 fprintf(fp,"$ 'c'\n");
3722 fprintf(fp,"$ perl_status = $STATUS\n");
3723 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3724 fprintf(fp,"$ perl_exit 'perl_status'\n");
3727 fgetname(fp, file, 1);
3728 fstat(fileno(fp), (struct stat *)&s0);
3731 if (decc_filename_unix_only)
3732 do_tounixspec(file, file, 0, NULL);
3733 fp = fopen(file,"r","shr=get");
3735 fstat(fileno(fp), (struct stat *)&s1);
3737 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3738 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3747 #ifdef USE_VMS_DECTERM
3749 static int vms_is_syscommand_xterm(void)
3751 const static struct dsc$descriptor_s syscommand_dsc =
3752 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3754 const static struct dsc$descriptor_s decwdisplay_dsc =
3755 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3757 struct item_list_3 items[2];
3758 unsigned short dvi_iosb[4];
3759 unsigned long devchar;
3760 unsigned long devclass;
3763 /* Very simple check to guess if sys$command is a decterm? */
3764 /* First see if the DECW$DISPLAY: device exists */
3766 items[0].code = DVI$_DEVCHAR;
3767 items[0].bufadr = &devchar;
3768 items[0].retadr = NULL;
3772 status = sys$getdviw
3773 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3775 if ($VMS_STATUS_SUCCESS(status)) {
3776 status = dvi_iosb[0];
3779 if (!$VMS_STATUS_SUCCESS(status)) {
3780 SETERRNO(EVMSERR, status);
3784 /* If it does, then for now assume that we are on a workstation */
3785 /* Now verify that SYS$COMMAND is a terminal */
3786 /* for creating the debugger DECTerm */
3789 items[0].code = DVI$_DEVCLASS;
3790 items[0].bufadr = &devclass;
3791 items[0].retadr = NULL;
3795 status = sys$getdviw
3796 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3798 if ($VMS_STATUS_SUCCESS(status)) {
3799 status = dvi_iosb[0];
3802 if (!$VMS_STATUS_SUCCESS(status)) {
3803 SETERRNO(EVMSERR, status);
3807 if (devclass == DC$_TERM) {
3814 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3815 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3820 char device_name[65];
3821 unsigned short device_name_len;
3822 struct dsc$descriptor_s customization_dsc;
3823 struct dsc$descriptor_s device_name_dsc;
3826 char customization[200];
3830 unsigned short p_chan;
3832 unsigned short iosb[4];
3833 struct item_list_3 items[2];
3834 const char * cust_str =
3835 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3836 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3837 DSC$K_CLASS_S, mbx1};
3839 ret_char = strstr(cmd," xterm ");
3840 if (ret_char == NULL)
3842 cptr = ret_char + 7;
3843 ret_char = strstr(cmd,"tty");
3844 if (ret_char == NULL)
3846 ret_char = strstr(cmd,"sleep");
3847 if (ret_char == NULL)
3850 /* Are we on a workstation? */
3851 /* to do: capture the rows / columns and pass their properties */
3852 ret_stat = vms_is_syscommand_xterm();
3856 /* Make the title: */
3857 ret_char = strstr(cptr,"-title");
3858 if (ret_char != NULL) {
3859 while ((*cptr != 0) && (*cptr != '\"')) {
3865 while ((*cptr != 0) && (*cptr != '\"')) {
3878 strcpy(title,"Perl Debug DECTerm");
3880 sprintf(customization, cust_str, title);
3882 customization_dsc.dsc$a_pointer = customization;
3883 customization_dsc.dsc$w_length = strlen(customization);
3884 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3885 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3887 device_name_dsc.dsc$a_pointer = device_name;
3888 device_name_dsc.dsc$w_length = sizeof device_name -1;
3889 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3890 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3892 device_name_len = 0;
3894 /* Try to create the window */
3895 status = decw$term_port
3904 if (!$VMS_STATUS_SUCCESS(status)) {
3905 SETERRNO(EVMSERR, status);
3909 device_name[device_name_len] = '\0';
3911 /* Need to set this up to look like a pipe for cleanup */
3913 status = lib$get_vm(&n, &info);
3914 if (!$VMS_STATUS_SUCCESS(status)) {
3915 SETERRNO(ENOMEM, status);
3921 info->completion = 0;
3922 info->closing = FALSE;
3929 info->in_done = TRUE;
3930 info->out_done = TRUE;
3931 info->err_done = TRUE;
3933 /* Assign a channel on this so that it will persist, and not login */
3934 /* We stash this channel in the info structure for reference. */
3935 /* The created xterm self destructs when the last channel is removed */
3936 /* and it appears that perl5db.pl (perl debugger) does this routinely */
3937 /* So leave this assigned. */
3938 device_name_dsc.dsc$w_length = device_name_len;
3939 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
3940 if (!$VMS_STATUS_SUCCESS(status)) {
3941 SETERRNO(EVMSERR, status);
3944 info->xchan_valid = 1;
3946 /* Now create a mailbox to be read by the application */
3948 create_mbx(aTHX_ &p_chan, &d_mbx1);
3950 /* write the name of the created terminal to the mailbox */
3951 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
3952 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
3954 if (!$VMS_STATUS_SUCCESS(status)) {
3955 SETERRNO(EVMSERR, status);
3959 info->fp = PerlIO_open(mbx1, mode);
3961 /* Done with this channel */
3964 /* If any errors, then clean up */
3967 _ckvmssts(lib$free_vm(&n, &info));
3977 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3979 static int handler_set_up = FALSE;
3980 unsigned long int sts, flags = CLI$M_NOWAIT;
3981 /* The use of a GLOBAL table (as was done previously) rendered
3982 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3983 * environment. Hence we've switched to LOCAL symbol table.
3985 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3987 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3988 char *in, *out, *err, mbx[512];
3990 char tfilebuf[NAM$C_MAXRSS+1];
3992 char cmd_sym_name[20];
3993 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3994 DSC$K_CLASS_S, symbol};
3995 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3997 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3998 DSC$K_CLASS_S, cmd_sym_name};
3999 struct dsc$descriptor_s *vmscmd;
4000 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4001 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4002 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4004 #ifdef USE_VMS_DECTERM
4005 /* Check here for Xterm create request. This means looking for
4006 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4007 * is possible to create an xterm.
4009 if (*in_mode == 'r') {
4012 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4013 if (xterm_fd != Nullfp)
4018 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4020 /* once-per-program initialization...
4021 note that the SETAST calls and the dual test of pipe_ef
4022 makes sure that only the FIRST thread through here does
4023 the initialization...all other threads wait until it's
4026 Yeah, uglier than a pthread call, it's got all the stuff inline
4027 rather than in a separate routine.
4031 _ckvmssts(sys$setast(0));
4033 unsigned long int pidcode = JPI$_PID;
4034 $DESCRIPTOR(d_delay, RETRY_DELAY);
4035 _ckvmssts(lib$get_ef(&pipe_ef));
4036 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4037 _ckvmssts(sys$bintim(&d_delay, delaytime));
4039 if (!handler_set_up) {
4040 _ckvmssts(sys$dclexh(&pipe_exitblock));
4041 handler_set_up = TRUE;
4043 _ckvmssts(sys$setast(1));
4046 /* see if we can find a VMSPIPE.COM */
4049 vmspipe = find_vmspipe(aTHX);
4051 strcpy(tfilebuf+1,vmspipe);
4052 } else { /* uh, oh...we're in tempfile hell */
4053 tpipe = vmspipe_tempfile(aTHX);
4054 if (!tpipe) { /* a fish popular in Boston */
4055 if (ckWARN(WARN_PIPE)) {
4056 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4060 fgetname(tpipe,tfilebuf+1,1);
4062 vmspipedsc.dsc$a_pointer = tfilebuf;
4063 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4065 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4068 case RMS$_FNF: case RMS$_DNF:
4069 set_errno(ENOENT); break;
4071 set_errno(ENOTDIR); break;
4073 set_errno(ENODEV); break;
4075 set_errno(EACCES); break;
4077 set_errno(EINVAL); break;
4078 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4079 set_errno(E2BIG); break;
4080 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4081 _ckvmssts(sts); /* fall through */
4082 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4085 set_vaxc_errno(sts);
4086 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4087 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4093 _ckvmssts(lib$get_vm(&n, &info));
4095 strcpy(mode,in_mode);
4098 info->completion = 0;
4099 info->closing = FALSE;
4106 info->in_done = TRUE;
4107 info->out_done = TRUE;
4108 info->err_done = TRUE;
4110 info->xchan_valid = 0;
4112 in = PerlMem_malloc(VMS_MAXRSS);
4113 if (in == NULL) _ckvmssts(SS$_INSFMEM);
4114 out = PerlMem_malloc(VMS_MAXRSS);
4115 if (out == NULL) _ckvmssts(SS$_INSFMEM);
4116 err = PerlMem_malloc(VMS_MAXRSS);
4117 if (err == NULL) _ckvmssts(SS$_INSFMEM);
4119 in[0] = out[0] = err[0] = '\0';
4121 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4125 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4130 if (*mode == 'r') { /* piping from subroutine */
4132 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4134 info->out->pipe_done = &info->out_done;
4135 info->out_done = FALSE;
4136 info->out->info = info;
4138 if (!info->useFILE) {
4139 info->fp = PerlIO_open(mbx, mode);
4141 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4142 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4145 if (!info->fp && info->out) {
4146 sys$cancel(info->out->chan_out);
4148 while (!info->out_done) {
4150 _ckvmssts(sys$setast(0));
4151 done = info->out_done;
4152 if (!done) _ckvmssts(sys$clref(pipe_ef));
4153 _ckvmssts(sys$setast(1));
4154 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4157 if (info->out->buf) {
4158 n = info->out->bufsize * sizeof(char);
4159 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4162 _ckvmssts(lib$free_vm(&n, &info->out));
4164 _ckvmssts(lib$free_vm(&n, &info));
4169 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4171 info->err->pipe_done = &info->err_done;
4172 info->err_done = FALSE;
4173 info->err->info = info;
4176 } else if (*mode == 'w') { /* piping to subroutine */
4178 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4180 info->out->pipe_done = &info->out_done;
4181 info->out_done = FALSE;
4182 info->out->info = info;
4185 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4187 info->err->pipe_done = &info->err_done;
4188 info->err_done = FALSE;
4189 info->err->info = info;
4192 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4193 if (!info->useFILE) {
4194 info->fp = PerlIO_open(mbx, mode);
4196 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4197 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4201 info->in->pipe_done = &info->in_done;
4202 info->in_done = FALSE;
4203 info->in->info = info;
4207 if (!info->fp && info->in) {
4209 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4210 0, 0, 0, 0, 0, 0, 0, 0));
4212 while (!info->in_done) {
4214 _ckvmssts(sys$setast(0));
4215 done = info->in_done;
4216 if (!done) _ckvmssts(sys$clref(pipe_ef));
4217 _ckvmssts(sys$setast(1));
4218 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4221 if (info->in->buf) {
4222 n = info->in->bufsize * sizeof(char);
4223 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4226 _ckvmssts(lib$free_vm(&n, &info->in));
4228 _ckvmssts(lib$free_vm(&n, &info));
4234 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4235 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4237 info->out->pipe_done = &info->out_done;
4238 info->out_done = FALSE;
4239 info->out->info = info;
4242 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4244 info->err->pipe_done = &info->err_done;
4245 info->err_done = FALSE;
4246 info->err->info = info;
4250 symbol[MAX_DCL_SYMBOL] = '\0';
4252 strncpy(symbol, in, MAX_DCL_SYMBOL);
4253 d_symbol.dsc$w_length = strlen(symbol);
4254 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4256 strncpy(symbol, err, MAX_DCL_SYMBOL);
4257 d_symbol.dsc$w_length = strlen(symbol);
4258 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4260 strncpy(symbol, out, MAX_DCL_SYMBOL);
4261 d_symbol.dsc$w_length = strlen(symbol);
4262 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4264 /* Done with the names for the pipes */
4269 p = vmscmd->dsc$a_pointer;
4270 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4271 if (*p == '$') p++; /* remove leading $ */
4272 while (*p == ' ' || *p == '\t') p++;
4274 for (j = 0; j < 4; j++) {
4275 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4276 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4278 strncpy(symbol, p, MAX_DCL_SYMBOL);
4279 d_symbol.dsc$w_length = strlen(symbol);
4280 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4282 if (strlen(p) > MAX_DCL_SYMBOL) {
4283 p += MAX_DCL_SYMBOL;
4288 _ckvmssts(sys$setast(0));
4289 info->next=open_pipes; /* prepend to list */
4291 _ckvmssts(sys$setast(1));
4292 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4293 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4294 * have SYS$COMMAND if we need it.
4296 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4297 0, &info->pid, &info->completion,
4298 0, popen_completion_ast,info,0,0,0));
4300 /* if we were using a tempfile, close it now */
4302 if (tpipe) fclose(tpipe);
4304 /* once the subprocess is spawned, it has copied the symbols and
4305 we can get rid of ours */
4307 for (j = 0; j < 4; j++) {
4308 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4309 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4310 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4312 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4313 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4314 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4315 vms_execfree(vmscmd);
4317 #ifdef PERL_IMPLICIT_CONTEXT
4320 PL_forkprocess = info->pid;
4325 _ckvmssts(sys$setast(0));
4327 if (!done) _ckvmssts(sys$clref(pipe_ef));
4328 _ckvmssts(sys$setast(1));
4329 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4331 *psts = info->completion;
4332 /* Caller thinks it is open and tries to close it. */
4333 /* This causes some problems, as it changes the error status */
4334 /* my_pclose(info->fp); */
4339 } /* end of safe_popen */
4342 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4344 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4348 TAINT_PROPER("popen");
4349 PERL_FLUSHALL_FOR_CHILD;
4350 return safe_popen(aTHX_ cmd,mode,&sts);
4355 /*{{{ I32 my_pclose(PerlIO *fp)*/
4356 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4358 pInfo info, last = NULL;
4359 unsigned long int retsts;
4363 for (info = open_pipes; info != NULL; last = info, info = info->next)
4364 if (info->fp == fp) break;
4366 if (info == NULL) { /* no such pipe open */
4367 set_errno(ECHILD); /* quoth POSIX */
4368 set_vaxc_errno(SS$_NONEXPR);
4372 /* If we were writing to a subprocess, insure that someone reading from
4373 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4374 * produce an EOF record in the mailbox.
4376 * well, at least sometimes it *does*, so we have to watch out for
4377 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4381 PerlIO_flush(info->fp); /* first, flush data */
4383 fflush((FILE *)info->fp);
4386 _ckvmssts(sys$setast(0));
4387 info->closing = TRUE;
4388 done = info->done && info->in_done && info->out_done && info->err_done;
4389 /* hanging on write to Perl's input? cancel it */
4390 if (info->mode == 'r' && info->out && !info->out_done) {
4391 if (info->out->chan_out) {
4392 _ckvmssts(sys$cancel(info->out->chan_out));
4393 if (!info->out->chan_in) { /* EOF generation, need AST */
4394 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4398 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4399 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4401 _ckvmssts(sys$setast(1));
4404 PerlIO_close(info->fp);
4406 fclose((FILE *)info->fp);
4409 we have to wait until subprocess completes, but ALSO wait until all
4410 the i/o completes...otherwise we'll be freeing the "info" structure
4411 that the i/o ASTs could still be using...
4415 _ckvmssts(sys$setast(0));
4416 done = info->done && info->in_done && info->out_done && info->err_done;
4417 if (!done) _ckvmssts(sys$clref(pipe_ef));
4418 _ckvmssts(sys$setast(1));
4419 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4421 retsts = info->completion;
4423 /* remove from list of open pipes */
4424 _ckvmssts(sys$setast(0));
4425 if (last) last->next = info->next;
4426 else open_pipes = info->next;
4427 _ckvmssts(sys$setast(1));
4429 /* free buffers and structures */
4432 if (info->in->buf) {
4433 n = info->in->bufsize * sizeof(char);
4434 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4437 _ckvmssts(lib$free_vm(&n, &info->in));
4440 if (info->out->buf) {
4441 n = info->out->bufsize * sizeof(char);
4442 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4445 _ckvmssts(lib$free_vm(&n, &info->out));
4448 if (info->err->buf) {
4449 n = info->err->bufsize * sizeof(char);
4450 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4453 _ckvmssts(lib$free_vm(&n, &info->err));
4456 _ckvmssts(lib$free_vm(&n, &info));
4460 } /* end of my_pclose() */
4462 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4463 /* Roll our own prototype because we want this regardless of whether
4464 * _VMS_WAIT is defined.
4466 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4468 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4469 created with popen(); otherwise partially emulate waitpid() unless
4470 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4471 Also check processes not considered by the CRTL waitpid().
4473 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4475 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4482 if (statusp) *statusp = 0;
4484 for (info = open_pipes; info != NULL; info = info->next)
4485 if (info->pid == pid) break;
4487 if (info != NULL) { /* we know about this child */
4488 while (!info->done) {
4489 _ckvmssts(sys$setast(0));
4491 if (!done) _ckvmssts(sys$clref(pipe_ef));
4492 _ckvmssts(sys$setast(1));
4493 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4496 if (statusp) *statusp = info->completion;
4500 /* child that already terminated? */
4502 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4503 if (closed_list[j].pid == pid) {
4504 if (statusp) *statusp = closed_list[j].completion;
4509 /* fall through if this child is not one of our own pipe children */
4511 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4513 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4514 * in 7.2 did we get a version that fills in the VMS completion
4515 * status as Perl has always tried to do.
4518 sts = __vms_waitpid( pid, statusp, flags );
4520 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4523 /* If the real waitpid tells us the child does not exist, we
4524 * fall through here to implement waiting for a child that
4525 * was created by some means other than exec() (say, spawned
4526 * from DCL) or to wait for a process that is not a subprocess
4527 * of the current process.
4530 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4533 $DESCRIPTOR(intdsc,"0 00:00:01");
4534 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4535 unsigned long int pidcode = JPI$_PID, mypid;
4536 unsigned long int interval[2];
4537 unsigned int jpi_iosb[2];
4538 struct itmlst_3 jpilist[2] = {
4539 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4544 /* Sorry folks, we don't presently implement rooting around for
4545 the first child we can find, and we definitely don't want to
4546 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4552 /* Get the owner of the child so I can warn if it's not mine. If the
4553 * process doesn't exist or I don't have the privs to look at it,
4554 * I can go home early.
4556 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4557 if (sts & 1) sts = jpi_iosb[0];
4569 set_vaxc_errno(sts);
4573 if (ckWARN(WARN_EXEC)) {
4574 /* remind folks they are asking for non-standard waitpid behavior */
4575 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4576 if (ownerpid != mypid)
4577 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4578 "waitpid: process %x is not a child of process %x",
4582 /* simply check on it once a second until it's not there anymore. */
4584 _ckvmssts(sys$bintim(&intdsc,interval));
4585 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4586 _ckvmssts(sys$schdwk(0,0,interval,0));
4587 _ckvmssts(sys$hiber());
4589 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4594 } /* end of waitpid() */
4599 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4601 my_gconvert(double val, int ndig, int trail, char *buf)
4603 static char __gcvtbuf[DBL_DIG+1];
4606 loc = buf ? buf : __gcvtbuf;
4608 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4610 sprintf(loc,"%.*g",ndig,val);
4616 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4617 return gcvt(val,ndig,loc);
4620 loc[0] = '0'; loc[1] = '\0';
4627 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4628 static int rms_free_search_context(struct FAB * fab)
4632 nam = fab->fab$l_nam;
4633 nam->nam$b_nop |= NAM$M_SYNCHK;
4634 nam->nam$l_rlf = NULL;
4636 return sys$parse(fab, NULL, NULL);
4639 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4640 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4641 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4642 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4643 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4644 #define rms_nam_esll(nam) nam.nam$b_esl
4645 #define rms_nam_esl(nam) nam.nam$b_esl
4646 #define rms_nam_name(nam) nam.nam$l_name
4647 #define rms_nam_namel(nam) nam.nam$l_name
4648 #define rms_nam_type(nam) nam.nam$l_type
4649 #define rms_nam_typel(nam) nam.nam$l_type
4650 #define rms_nam_ver(nam) nam.nam$l_ver
4651 #define rms_nam_verl(nam) nam.nam$l_ver
4652 #define rms_nam_rsll(nam) nam.nam$b_rsl
4653 #define rms_nam_rsl(nam) nam.nam$b_rsl
4654 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4655 #define rms_set_fna(fab, nam, name, size) \
4656 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4657 #define rms_get_fna(fab, nam) fab.fab$l_fna
4658 #define rms_set_dna(fab, nam, name, size) \
4659 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4660 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4661 #define rms_set_esa(fab, nam, name, size) \
4662 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4663 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4664 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4665 #define rms_set_rsa(nam, name, size) \
4666 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4667 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4668 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4669 #define rms_nam_name_type_l_size(nam) \
4670 (nam.nam$b_name + nam.nam$b_type)
4672 static int rms_free_search_context(struct FAB * fab)
4676 nam = fab->fab$l_naml;
4677 nam->naml$b_nop |= NAM$M_SYNCHK;
4678 nam->naml$l_rlf = NULL;
4679 nam->naml$l_long_defname_size = 0;
4682 return sys$parse(fab, NULL, NULL);
4685 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4686 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4687 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4688 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4689 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4690 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4691 #define rms_nam_esl(nam) nam.naml$b_esl
4692 #define rms_nam_name(nam) nam.naml$l_name
4693 #define rms_nam_namel(nam) nam.naml$l_long_name
4694 #define rms_nam_type(nam) nam.naml$l_type
4695 #define rms_nam_typel(nam) nam.naml$l_long_type
4696 #define rms_nam_ver(nam) nam.naml$l_ver
4697 #define rms_nam_verl(nam) nam.naml$l_long_ver
4698 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4699 #define rms_nam_rsl(nam) nam.naml$b_rsl
4700 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4701 #define rms_set_fna(fab, nam, name, size) \
4702 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4703 nam.naml$l_long_filename_size = size; \
4704 nam.naml$l_long_filename = name;}
4705 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4706 #define rms_set_dna(fab, nam, name, size) \
4707 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4708 nam.naml$l_long_defname_size = size; \
4709 nam.naml$l_long_defname = name; }
4710 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4711 #define rms_set_esa(fab, nam, name, size) \
4712 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4713 nam.naml$l_long_expand_alloc = size; \
4714 nam.naml$l_long_expand = name; }
4715 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4716 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4717 nam.naml$l_long_expand = l_name; \
4718 nam.naml$l_long_expand_alloc = l_size; }
4719 #define rms_set_rsa(nam, name, size) \
4720 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4721 nam.naml$l_long_result = name; \
4722 nam.naml$l_long_result_alloc = size; }
4723 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4724 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4725 nam.naml$l_long_result = l_name; \
4726 nam.naml$l_long_result_alloc = l_size; }
4727 #define rms_nam_name_type_l_size(nam) \
4728 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4732 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4733 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4734 * to expand file specification. Allows for a single default file
4735 * specification and a simple mask of options. If outbuf is non-NULL,
4736 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4737 * the resultant file specification is placed. If outbuf is NULL, the
4738 * resultant file specification is placed into a static buffer.
4739 * The third argument, if non-NULL, is taken to be a default file
4740 * specification string. The fourth argument is unused at present.
4741 * rmesexpand() returns the address of the resultant string if
4742 * successful, and NULL on error.
4744 * New functionality for previously unused opts value:
4745 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4746 * PERL_RMSEXPAND_M_LONG - Want output in long formst
4747 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4749 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4753 (pTHX_ const char *filespec,
4756 const char *defspec,
4761 static char __rmsexpand_retbuf[VMS_MAXRSS];
4762 char * vmsfspec, *tmpfspec;
4763 char * esa, *cp, *out = NULL;
4767 struct FAB myfab = cc$rms_fab;
4768 rms_setup_nam(mynam);
4770 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4773 /* temp hack until UTF8 is actually implemented */
4774 if (fs_utf8 != NULL)
4777 if (!filespec || !*filespec) {
4778 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4782 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4783 else outbuf = __rmsexpand_retbuf;
4791 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4792 isunix = is_unix_filespec(filespec);
4794 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4795 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4796 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4797 PerlMem_free(vmsfspec);
4802 filespec = vmsfspec;
4804 /* Unless we are forcing to VMS format, a UNIX input means
4805 * UNIX output, and that requires long names to be used
4807 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4808 opts |= PERL_RMSEXPAND_M_LONG;
4815 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4816 rms_bind_fab_nam(myfab, mynam);
4818 if (defspec && *defspec) {
4820 t_isunix = is_unix_filespec(defspec);
4822 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4823 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4824 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4825 PerlMem_free(tmpfspec);
4826 if (vmsfspec != NULL)
4827 PerlMem_free(vmsfspec);
4834 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4837 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4838 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4839 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4840 esal = PerlMem_malloc(VMS_MAXRSS);
4841 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4843 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4845 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4846 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4849 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4850 outbufl = PerlMem_malloc(VMS_MAXRSS);
4851 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4852 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4854 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4858 #ifdef NAM$M_NO_SHORT_UPCASE
4859 if (decc_efs_case_preserve)
4860 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4863 /* First attempt to parse as an existing file */
4864 retsts = sys$parse(&myfab,0,0);
4865 if (!(retsts & STS$K_SUCCESS)) {
4867 /* Could not find the file, try as syntax only if error is not fatal */
4868 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4869 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4870 retsts = sys$parse(&myfab,0,0);
4871 if (retsts & STS$K_SUCCESS) goto expanded;
4874 /* Still could not parse the file specification */
4875 /*----------------------------------------------*/
4876 sts = rms_free_search_context(&myfab); /* Free search context */
4877 if (out) Safefree(out);
4878 if (tmpfspec != NULL)
4879 PerlMem_free(tmpfspec);
4880 if (vmsfspec != NULL)
4881 PerlMem_free(vmsfspec);
4882 if (outbufl != NULL)
4883 PerlMem_free(outbufl);
4886 set_vaxc_errno(retsts);
4887 if (retsts == RMS$_PRV) set_errno(EACCES);
4888 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4889 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4890 else set_errno(EVMSERR);
4893 retsts = sys$search(&myfab,0,0);
4894 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4895 sts = rms_free_search_context(&myfab); /* Free search context */
4896 if (out) Safefree(out);
4897 if (tmpfspec != NULL)
4898 PerlMem_free(tmpfspec);
4899 if (vmsfspec != NULL)
4900 PerlMem_free(vmsfspec);
4901 if (outbufl != NULL)
4902 PerlMem_free(outbufl);
4905 set_vaxc_errno(retsts);
4906 if (retsts == RMS$_PRV) set_errno(EACCES);
4907 else set_errno(EVMSERR);
4911 /* If the input filespec contained any lowercase characters,
4912 * downcase the result for compatibility with Unix-minded code. */
4914 if (!decc_efs_case_preserve) {
4915 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4916 if (islower(*tbuf)) { haslower = 1; break; }
4919 /* Is a long or a short name expected */
4920 /*------------------------------------*/
4921 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4922 if (rms_nam_rsll(mynam)) {
4924 speclen = rms_nam_rsll(mynam);
4927 tbuf = esal; /* Not esa */
4928 speclen = rms_nam_esll(mynam);
4932 if (rms_nam_rsl(mynam)) {
4934 speclen = rms_nam_rsl(mynam);
4937 tbuf = esa; /* Not esal */
4938 speclen = rms_nam_esl(mynam);
4941 tbuf[speclen] = '\0';
4943 /* Trim off null fields added by $PARSE
4944 * If type > 1 char, must have been specified in original or default spec
4945 * (not true for version; $SEARCH may have added version of existing file).
4947 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4948 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4949 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4950 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4953 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4954 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4956 if (trimver || trimtype) {
4957 if (defspec && *defspec) {
4958 char *defesal = NULL;
4959 defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4960 if (defesal != NULL) {
4961 struct FAB deffab = cc$rms_fab;
4962 rms_setup_nam(defnam);
4964 rms_bind_fab_nam(deffab, defnam);
4968 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4970 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4972 rms_clear_nam_nop(defnam);
4973 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4974 #ifdef NAM$M_NO_SHORT_UPCASE
4975 if (decc_efs_case_preserve)
4976 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4978 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4980 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4983 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4986 PerlMem_free(defesal);
4990 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4991 if (*(rms_nam_verl(mynam)) != '\"')
4992 speclen = rms_nam_verl(mynam) - tbuf;
4995 if (*(rms_nam_ver(mynam)) != '\"')
4996 speclen = rms_nam_ver(mynam) - tbuf;
5000 /* If we didn't already trim version, copy down */
5001 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5002 if (speclen > rms_nam_verl(mynam) - tbuf)
5004 (rms_nam_typel(mynam),
5005 rms_nam_verl(mynam),
5006 speclen - (rms_nam_verl(mynam) - tbuf));
5007 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5010 if (speclen > rms_nam_ver(mynam) - tbuf)
5012 (rms_nam_type(mynam),
5014 speclen - (rms_nam_ver(mynam) - tbuf));
5015 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5020 /* Done with these copies of the input files */
5021 /*-------------------------------------------*/
5022 if (vmsfspec != NULL)
5023 PerlMem_free(vmsfspec);
5024 if (tmpfspec != NULL)
5025 PerlMem_free(tmpfspec);
5027 /* If we just had a directory spec on input, $PARSE "helpfully"
5028 * adds an empty name and type for us */
5029 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5030 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5031 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5032 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5033 speclen = rms_nam_namel(mynam) - tbuf;
5036 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5037 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5038 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5039 speclen = rms_nam_name(mynam) - tbuf;
5042 /* Posix format specifications must have matching quotes */
5043 if (speclen < (VMS_MAXRSS - 1)) {
5044 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5045 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5046 tbuf[speclen] = '\"';
5051 tbuf[speclen] = '\0';
5052 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5054 /* Have we been working with an expanded, but not resultant, spec? */
5055 /* Also, convert back to Unix syntax if necessary. */
5057 if (!rms_nam_rsll(mynam)) {
5059 if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
5060 if (out) Safefree(out);
5063 if (outbufl != NULL)
5064 PerlMem_free(outbufl);
5068 else strcpy(outbuf,esa);
5071 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5072 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5073 if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5074 if (out) Safefree(out);
5077 PerlMem_free(tmpfspec);
5078 if (outbufl != NULL)
5079 PerlMem_free(outbufl);
5082 strcpy(outbuf,tmpfspec);
5083 PerlMem_free(tmpfspec);
5086 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5087 sts = rms_free_search_context(&myfab); /* Free search context */
5090 if (outbufl != NULL)
5091 PerlMem_free(outbufl);
5095 /* External entry points */
5096 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5097 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5098 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5099 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5100 char *Perl_rmsexpand_utf8
5101 (pTHX_ const char *spec, char *buf, const char *def,
5102 unsigned opt, int * fs_utf8, int * dfs_utf8)
5103 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5104 char *Perl_rmsexpand_utf8_ts
5105 (pTHX_ const char *spec, char *buf, const char *def,
5106 unsigned opt, int * fs_utf8, int * dfs_utf8)
5107 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5111 ** The following routines are provided to make life easier when
5112 ** converting among VMS-style and Unix-style directory specifications.
5113 ** All will take input specifications in either VMS or Unix syntax. On
5114 ** failure, all return NULL. If successful, the routines listed below
5115 ** return a pointer to a buffer containing the appropriately
5116 ** reformatted spec (and, therefore, subsequent calls to that routine
5117 ** will clobber the result), while the routines of the same names with
5118 ** a _ts suffix appended will return a pointer to a mallocd string
5119 ** containing the appropriately reformatted spec.
5120 ** In all cases, only explicit syntax is altered; no check is made that
5121 ** the resulting string is valid or that the directory in question
5124 ** fileify_dirspec() - convert a directory spec into the name of the
5125 ** directory file (i.e. what you can stat() to see if it's a dir).
5126 ** The style (VMS or Unix) of the result is the same as the style
5127 ** of the parameter passed in.
5128 ** pathify_dirspec() - convert a directory spec into a path (i.e.
5129 ** what you prepend to a filename to indicate what directory it's in).
5130 ** The style (VMS or Unix) of the result is the same as the style
5131 ** of the parameter passed in.
5132 ** tounixpath() - convert a directory spec into a Unix-style path.
5133 ** tovmspath() - convert a directory spec into a VMS-style path.
5134 ** tounixspec() - convert any file spec into a Unix-style file spec.
5135 ** tovmsspec() - convert any file spec into a VMS-style spec.
5136 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5138 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
5139 ** Permission is given to distribute this code as part of the Perl
5140 ** standard distribution under the terms of the GNU General Public
5141 ** License or the Perl Artistic License. Copies of each may be
5142 ** found in the Perl standard distribution.
5145 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5146 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5148 static char __fileify_retbuf[VMS_MAXRSS];
5149 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5150 char *retspec, *cp1, *cp2, *lastdir;
5151 char *trndir, *vmsdir;
5152 unsigned short int trnlnm_iter_count;
5154 if (utf8_fl != NULL)
5157 if (!dir || !*dir) {
5158 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5160 dirlen = strlen(dir);
5161 while (dirlen && dir[dirlen-1] == '/') --dirlen;
5162 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5163 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5170 if (dirlen > (VMS_MAXRSS - 1)) {
5171 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5174 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5175 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5176 if (!strpbrk(dir+1,"/]>:") &&
5177 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5178 strcpy(trndir,*dir == '/' ? dir + 1: dir);
5179 trnlnm_iter_count = 0;
5180 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
5181 trnlnm_iter_count++;
5182 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5184 dirlen = strlen(trndir);
5187 strncpy(trndir,dir,dirlen);
5188 trndir[dirlen] = '\0';
5191 /* At this point we are done with *dir and use *trndir which is a
5192 * copy that can be modified. *dir must not be modified.
5195 /* If we were handed a rooted logical name or spec, treat it like a
5196 * simple directory, so that
5197 * $ Define myroot dev:[dir.]
5198 * ... do_fileify_dirspec("myroot",buf,1) ...
5199 * does something useful.
5201 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5202 trndir[--dirlen] = '\0';
5203 trndir[dirlen-1] = ']';
5205 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5206 trndir[--dirlen] = '\0';
5207 trndir[dirlen-1] = '>';
5210 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5211 /* If we've got an explicit filename, we can just shuffle the string. */
5212 if (*(cp1+1)) hasfilename = 1;
5213 /* Similarly, we can just back up a level if we've got multiple levels
5214 of explicit directories in a VMS spec which ends with directories. */
5216 for (cp2 = cp1; cp2 > trndir; cp2--) {
5218 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5219 /* fix-me, can not scan EFS file specs backward like this */
5220 *cp2 = *cp1; *cp1 = '\0';
5225 if (*cp2 == '[' || *cp2 == '<') break;
5230 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5231 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5232 cp1 = strpbrk(trndir,"]:>");
5233 if (hasfilename || !cp1) { /* Unix-style path or filename */
5234 if (trndir[0] == '.') {
5235 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5236 PerlMem_free(trndir);
5237 PerlMem_free(vmsdir);
5238 return do_fileify_dirspec("[]",buf,ts,NULL);
5240 else if (trndir[1] == '.' &&
5241 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5242 PerlMem_free(trndir);
5243 PerlMem_free(vmsdir);
5244 return do_fileify_dirspec("[-]",buf,ts,NULL);
5247 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
5248 dirlen -= 1; /* to last element */
5249 lastdir = strrchr(trndir,'/');
5251 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5252 /* If we have "/." or "/..", VMSify it and let the VMS code
5253 * below expand it, rather than repeating the code to handle
5254 * relative components of a filespec here */
5256 if (*(cp1+2) == '.') cp1++;
5257 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5259 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5260 PerlMem_free(trndir);
5261 PerlMem_free(vmsdir);
5264 if (strchr(vmsdir,'/') != NULL) {
5265 /* If do_tovmsspec() returned it, it must have VMS syntax
5266 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5267 * the time to check this here only so we avoid a recursion
5268 * loop; otherwise, gigo.
5270 PerlMem_free(trndir);
5271 PerlMem_free(vmsdir);
5272 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5275 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5276 PerlMem_free(trndir);
5277 PerlMem_free(vmsdir);
5280 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5281 PerlMem_free(trndir);
5282 PerlMem_free(vmsdir);
5286 } while ((cp1 = strstr(cp1,"/.")) != NULL);
5287 lastdir = strrchr(trndir,'/');
5289 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5291 /* Ditto for specs that end in an MFD -- let the VMS code
5292 * figure out whether it's a real device or a rooted logical. */
5294 /* This should not happen any more. Allowing the fake /000000
5295 * in a UNIX pathname causes all sorts of problems when trying
5296 * to run in UNIX emulation. So the VMS to UNIX conversions
5297 * now remove the fake /000000 directories.
5300 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5301 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5302 PerlMem_free(trndir);
5303 PerlMem_free(vmsdir);
5306 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5307 PerlMem_free(trndir);
5308 PerlMem_free(vmsdir);
5311 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5312 PerlMem_free(trndir);
5313 PerlMem_free(vmsdir);
5318 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5319 !(lastdir = cp1 = strrchr(trndir,']')) &&
5320 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5321 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
5324 /* For EFS or ODS-5 look for the last dot */
5325 if (decc_efs_charset) {
5326 cp2 = strrchr(cp1,'.');
5328 if (vms_process_case_tolerant) {
5329 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5330 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5331 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5332 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5333 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5334 (ver || *cp3)))))) {
5335 PerlMem_free(trndir);
5336 PerlMem_free(vmsdir);
5338 set_vaxc_errno(RMS$_DIR);
5343 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5344 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5345 !*(cp2+3) || *(cp2+3) != 'R' ||
5346 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5347 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5348 (ver || *cp3)))))) {
5349 PerlMem_free(trndir);
5350 PerlMem_free(vmsdir);
5352 set_vaxc_errno(RMS$_DIR);
5356 dirlen = cp2 - trndir;
5360 retlen = dirlen + 6;
5361 if (buf) retspec = buf;
5362 else if (ts) Newx(retspec,retlen+1,char);
5363 else retspec = __fileify_retbuf;
5364 memcpy(retspec,trndir,dirlen);
5365 retspec[dirlen] = '\0';
5367 /* We've picked up everything up to the directory file name.
5368 Now just add the type and version, and we're set. */
5369 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5370 strcat(retspec,".dir;1");
5372 strcat(retspec,".DIR;1");
5373 PerlMem_free(trndir);
5374 PerlMem_free(vmsdir);
5377 else { /* VMS-style directory spec */
5379 char *esa, term, *cp;
5380 unsigned long int sts, cmplen, haslower = 0;
5381 unsigned int nam_fnb;
5383 struct FAB dirfab = cc$rms_fab;
5384 rms_setup_nam(savnam);
5385 rms_setup_nam(dirnam);
5387 esa = PerlMem_malloc(VMS_MAXRSS + 1);
5388 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5389 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5390 rms_bind_fab_nam(dirfab, dirnam);
5391 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5392 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5393 #ifdef NAM$M_NO_SHORT_UPCASE
5394 if (decc_efs_case_preserve)
5395 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5398 for (cp = trndir; *cp; cp++)
5399 if (islower(*cp)) { haslower = 1; break; }
5400 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5401 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5402 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5403 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5407 PerlMem_free(trndir);
5408 PerlMem_free(vmsdir);
5410 set_vaxc_errno(dirfab.fab$l_sts);
5416 /* Does the file really exist? */
5417 if (sys$search(&dirfab)& STS$K_SUCCESS) {
5418 /* Yes; fake the fnb bits so we'll check type below */
5419 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5421 else { /* No; just work with potential name */
5422 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5425 fab_sts = dirfab.fab$l_sts;
5426 sts = rms_free_search_context(&dirfab);
5428 PerlMem_free(trndir);
5429 PerlMem_free(vmsdir);
5430 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
5435 esa[rms_nam_esll(dirnam)] = '\0';
5436 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5437 cp1 = strchr(esa,']');
5438 if (!cp1) cp1 = strchr(esa,'>');
5439 if (cp1) { /* Should always be true */
5440 rms_nam_esll(dirnam) -= cp1 - esa - 1;
5441 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5444 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5445 /* Yep; check version while we're at it, if it's there. */
5446 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5447 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5448 /* Something other than .DIR[;1]. Bzzt. */
5449 sts = rms_free_search_context(&dirfab);
5451 PerlMem_free(trndir);
5452 PerlMem_free(vmsdir);
5454 set_vaxc_errno(RMS$_DIR);
5459 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5460 /* They provided at least the name; we added the type, if necessary, */
5461 if (buf) retspec = buf; /* in sys$parse() */
5462 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5463 else retspec = __fileify_retbuf;
5464 strcpy(retspec,esa);
5465 sts = rms_free_search_context(&dirfab);
5466 PerlMem_free(trndir);
5468 PerlMem_free(vmsdir);
5471 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5472 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5474 rms_nam_esll(dirnam) -= 9;
5476 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5477 if (cp1 == NULL) { /* should never happen */
5478 sts = rms_free_search_context(&dirfab);
5479 PerlMem_free(trndir);
5481 PerlMem_free(vmsdir);
5486 retlen = strlen(esa);
5487 cp1 = strrchr(esa,'.');
5488 /* ODS-5 directory specifications can have extra "." in them. */
5489 /* Fix-me, can not scan EFS file specifications backwards */
5490 while (cp1 != NULL) {
5491 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5495 while ((cp1 > esa) && (*cp1 != '.'))
5502 if ((cp1) != NULL) {
5503 /* There's more than one directory in the path. Just roll back. */
5505 if (buf) retspec = buf;
5506 else if (ts) Newx(retspec,retlen+7,char);
5507 else retspec = __fileify_retbuf;
5508 strcpy(retspec,esa);
5511 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5512 /* Go back and expand rooted logical name */
5513 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5514 #ifdef NAM$M_NO_SHORT_UPCASE
5515 if (decc_efs_case_preserve)
5516 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5518 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5519 sts = rms_free_search_context(&dirfab);
5521 PerlMem_free(trndir);
5522 PerlMem_free(vmsdir);
5524 set_vaxc_errno(dirfab.fab$l_sts);
5527 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5528 if (buf) retspec = buf;
5529 else if (ts) Newx(retspec,retlen+16,char);
5530 else retspec = __fileify_retbuf;
5531 cp1 = strstr(esa,"][");
5532 if (!cp1) cp1 = strstr(esa,"]<");
5534 memcpy(retspec,esa,dirlen);
5535 if (!strncmp(cp1+2,"000000]",7)) {
5536 retspec[dirlen-1] = '\0';
5537 /* fix-me Not full ODS-5, just extra dots in directories for now */
5538 cp1 = retspec + dirlen - 1;
5539 while (cp1 > retspec)
5544 if (*(cp1-1) != '^')
5549 if (*cp1 == '.') *cp1 = ']';
5551 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5552 memmove(cp1+1,"000000]",7);
5556 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5557 retspec[retlen] = '\0';
5558 /* Convert last '.' to ']' */
5559 cp1 = retspec+retlen-1;
5560 while (*cp != '[') {
5563 /* Do not trip on extra dots in ODS-5 directories */
5564 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5568 if (*cp1 == '.') *cp1 = ']';
5570 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5571 memmove(cp1+1,"000000]",7);
5575 else { /* This is a top-level dir. Add the MFD to the path. */
5576 if (buf) retspec = buf;
5577 else if (ts) Newx(retspec,retlen+16,char);
5578 else retspec = __fileify_retbuf;
5581 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5582 strcpy(cp2,":[000000]");
5587 sts = rms_free_search_context(&dirfab);
5588 /* We've set up the string up through the filename. Add the
5589 type and version, and we're done. */
5590 strcat(retspec,".DIR;1");
5592 /* $PARSE may have upcased filespec, so convert output to lower
5593 * case if input contained any lowercase characters. */
5594 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5595 PerlMem_free(trndir);
5597 PerlMem_free(vmsdir);
5600 } /* end of do_fileify_dirspec() */
5602 /* External entry points */
5603 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5604 { return do_fileify_dirspec(dir,buf,0,NULL); }
5605 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5606 { return do_fileify_dirspec(dir,buf,1,NULL); }
5607 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5608 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5609 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5610 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5612 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5613 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5615 static char __pathify_retbuf[VMS_MAXRSS];
5616 unsigned long int retlen;
5617 char *retpath, *cp1, *cp2, *trndir;
5618 unsigned short int trnlnm_iter_count;
5621 if (utf8_fl != NULL)
5624 if (!dir || !*dir) {
5625 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5628 trndir = PerlMem_malloc(VMS_MAXRSS);
5629 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5630 if (*dir) strcpy(trndir,dir);
5631 else getcwd(trndir,VMS_MAXRSS - 1);
5633 trnlnm_iter_count = 0;
5634 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5635 && my_trnlnm(trndir,trndir,0)) {
5636 trnlnm_iter_count++;
5637 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5638 trnlen = strlen(trndir);
5640 /* Trap simple rooted lnms, and return lnm:[000000] */
5641 if (!strcmp(trndir+trnlen-2,".]")) {
5642 if (buf) retpath = buf;
5643 else if (ts) Newx(retpath,strlen(dir)+10,char);
5644 else retpath = __pathify_retbuf;
5645 strcpy(retpath,dir);
5646 strcat(retpath,":[000000]");
5647 PerlMem_free(trndir);
5652 /* At this point we do not work with *dir, but the copy in
5653 * *trndir that is modifiable.
5656 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5657 if (*trndir == '.' && (*(trndir+1) == '\0' ||
5658 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5659 retlen = 2 + (*(trndir+1) != '\0');
5661 if ( !(cp1 = strrchr(trndir,'/')) &&
5662 !(cp1 = strrchr(trndir,']')) &&
5663 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5664 if ((cp2 = strchr(cp1,'.')) != NULL &&
5665 (*(cp2-1) != '/' || /* Trailing '.', '..', */
5666 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
5667 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5668 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5671 /* For EFS or ODS-5 look for the last dot */
5672 if (decc_efs_charset) {
5673 cp2 = strrchr(cp1,'.');
5675 if (vms_process_case_tolerant) {
5676 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5677 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5678 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5679 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5680 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5681 (ver || *cp3)))))) {
5682 PerlMem_free(trndir);
5684 set_vaxc_errno(RMS$_DIR);
5689 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5690 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5691 !*(cp2+3) || *(cp2+3) != 'R' ||
5692 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5693 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5694 (ver || *cp3)))))) {
5695 PerlMem_free(trndir);
5697 set_vaxc_errno(RMS$_DIR);
5701 retlen = cp2 - trndir + 1;
5703 else { /* No file type present. Treat the filename as a directory. */
5704 retlen = strlen(trndir) + 1;
5707 if (buf) retpath = buf;
5708 else if (ts) Newx(retpath,retlen+1,char);
5709 else retpath = __pathify_retbuf;
5710 strncpy(retpath, trndir, retlen-1);
5711 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5712 retpath[retlen-1] = '/'; /* with '/', add it. */
5713 retpath[retlen] = '\0';
5715 else retpath[retlen-1] = '\0';
5717 else { /* VMS-style directory spec */
5719 unsigned long int sts, cmplen, haslower;
5720 struct FAB dirfab = cc$rms_fab;
5722 rms_setup_nam(savnam);
5723 rms_setup_nam(dirnam);
5725 /* If we've got an explicit filename, we can just shuffle the string. */
5726 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5727 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
5728 if ((cp2 = strchr(cp1,'.')) != NULL) {
5730 if (vms_process_case_tolerant) {
5731 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5732 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5733 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5734 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5735 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5736 (ver || *cp3)))))) {
5737 PerlMem_free(trndir);
5739 set_vaxc_errno(RMS$_DIR);
5744 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5745 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5746 !*(cp2+3) || *(cp2+3) != 'R' ||
5747 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5748 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5749 (ver || *cp3)))))) {
5750 PerlMem_free(trndir);
5752 set_vaxc_errno(RMS$_DIR);
5757 else { /* No file type, so just draw name into directory part */
5758 for (cp2 = cp1; *cp2; cp2++) ;
5761 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5763 /* We've now got a VMS 'path'; fall through */
5766 dirlen = strlen(trndir);
5767 if (trndir[dirlen-1] == ']' ||
5768 trndir[dirlen-1] == '>' ||
5769 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5770 if (buf) retpath = buf;
5771 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5772 else retpath = __pathify_retbuf;
5773 strcpy(retpath,trndir);
5774 PerlMem_free(trndir);
5777 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5778 esa = PerlMem_malloc(VMS_MAXRSS);
5779 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5780 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5781 rms_bind_fab_nam(dirfab, dirnam);
5782 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5783 #ifdef NAM$M_NO_SHORT_UPCASE
5784 if (decc_efs_case_preserve)
5785 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5788 for (cp = trndir; *cp; cp++)
5789 if (islower(*cp)) { haslower = 1; break; }
5791 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5792 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5793 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5794 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5797 PerlMem_free(trndir);
5800 set_vaxc_errno(dirfab.fab$l_sts);
5806 /* Does the file really exist? */
5807 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5808 if (dirfab.fab$l_sts != RMS$_FNF) {
5810 sts1 = rms_free_search_context(&dirfab);
5811 PerlMem_free(trndir);
5814 set_vaxc_errno(dirfab.fab$l_sts);
5817 dirnam = savnam; /* No; just work with potential name */
5820 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5821 /* Yep; check version while we're at it, if it's there. */
5822 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5823 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5825 /* Something other than .DIR[;1]. Bzzt. */
5826 sts2 = rms_free_search_context(&dirfab);
5827 PerlMem_free(trndir);
5830 set_vaxc_errno(RMS$_DIR);
5834 /* OK, the type was fine. Now pull any file name into the
5836 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5838 cp1 = strrchr(esa,'>');
5839 *(rms_nam_typel(dirnam)) = '>';
5842 *(rms_nam_typel(dirnam) + 1) = '\0';
5843 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5844 if (buf) retpath = buf;
5845 else if (ts) Newx(retpath,retlen,char);
5846 else retpath = __pathify_retbuf;
5847 strcpy(retpath,esa);
5849 sts = rms_free_search_context(&dirfab);
5850 /* $PARSE may have upcased filespec, so convert output to lower
5851 * case if input contained any lowercase characters. */
5852 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5855 PerlMem_free(trndir);
5857 } /* end of do_pathify_dirspec() */
5859 /* External entry points */
5860 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5861 { return do_pathify_dirspec(dir,buf,0,NULL); }
5862 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5863 { return do_pathify_dirspec(dir,buf,1,NULL); }
5864 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5865 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5866 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5867 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5869 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5870 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5872 static char __tounixspec_retbuf[VMS_MAXRSS];
5873 char *dirend, *rslt, *cp1, *cp3, *tmp;
5875 int devlen, dirlen, retlen = VMS_MAXRSS;
5876 int expand = 1; /* guarantee room for leading and trailing slashes */
5877 unsigned short int trnlnm_iter_count;
5879 if (utf8_fl != NULL)
5882 if (spec == NULL) return NULL;
5883 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5884 if (buf) rslt = buf;
5886 Newx(rslt, VMS_MAXRSS, char);
5888 else rslt = __tounixspec_retbuf;
5890 /* New VMS specific format needs translation
5891 * glob passes filenames with trailing '\n' and expects this preserved.
5893 if (decc_posix_compliant_pathnames) {
5894 if (strncmp(spec, "\"^UP^", 5) == 0) {
5900 tunix = PerlMem_malloc(VMS_MAXRSS);
5901 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5902 strcpy(tunix, spec);
5903 tunix_len = strlen(tunix);
5905 if (tunix[tunix_len - 1] == '\n') {
5906 tunix[tunix_len - 1] = '\"';
5907 tunix[tunix_len] = '\0';
5911 uspec = decc$translate_vms(tunix);
5912 PerlMem_free(tunix);
5913 if ((int)uspec > 0) {
5919 /* If we can not translate it, makemaker wants as-is */
5927 cmp_rslt = 0; /* Presume VMS */
5928 cp1 = strchr(spec, '/');
5932 /* Look for EFS ^/ */
5933 if (decc_efs_charset) {
5934 while (cp1 != NULL) {
5937 /* Found illegal VMS, assume UNIX */
5942 cp1 = strchr(cp1, '/');
5946 /* Look for "." and ".." */
5947 if (decc_filename_unix_report) {
5948 if (spec[0] == '.') {
5949 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5953 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5959 /* This is already UNIX or at least nothing VMS understands */
5967 dirend = strrchr(spec,']');
5968 if (dirend == NULL) dirend = strrchr(spec,'>');
5969 if (dirend == NULL) dirend = strchr(spec,':');
5970 if (dirend == NULL) {
5975 /* Special case 1 - sys$posix_root = / */
5976 #if __CRTL_VER >= 70000000
5977 if (!decc_disable_posix_root) {
5978 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5986 /* Special case 2 - Convert NLA0: to /dev/null */
5987 #if __CRTL_VER < 70000000
5988 cmp_rslt = strncmp(spec,"NLA0:", 5);
5990 cmp_rslt = strncmp(spec,"nla0:", 5);
5992 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5994 if (cmp_rslt == 0) {
5995 strcpy(rslt, "/dev/null");
5998 if (spec[6] != '\0') {
6005 /* Also handle special case "SYS$SCRATCH:" */
6006 #if __CRTL_VER < 70000000
6007 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6009 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6011 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6013 tmp = PerlMem_malloc(VMS_MAXRSS);
6014 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6015 if (cmp_rslt == 0) {
6018 islnm = my_trnlnm(tmp, "TMP", 0);
6020 strcpy(rslt, "/tmp");
6023 if (spec[12] != '\0') {
6031 if (*cp2 != '[' && *cp2 != '<') {
6034 else { /* the VMS spec begins with directories */
6036 if (*cp2 == ']' || *cp2 == '>') {
6037 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6041 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6042 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6043 if (ts) Safefree(rslt);
6047 trnlnm_iter_count = 0;
6050 while (*cp3 != ':' && *cp3) cp3++;
6052 if (strchr(cp3,']') != NULL) break;
6053 trnlnm_iter_count++;
6054 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6055 } while (vmstrnenv(tmp,tmp,0,fildev,0));
6057 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6058 retlen = devlen + dirlen;
6059 Renew(rslt,retlen+1+2*expand,char);
6065 *(cp1++) = *(cp3++);
6066 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6068 return NULL; /* No room */
6073 if ((*cp2 == '^')) {
6074 /* EFS file escape, pass the next character as is */
6075 /* Fix me: HEX encoding for UNICODE not implemented */
6078 else if ( *cp2 == '.') {
6079 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6080 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6087 for (; cp2 <= dirend; cp2++) {
6088 if ((*cp2 == '^')) {
6089 /* EFS file escape, pass the next character as is */
6090 /* Fix me: HEX encoding for UNICODE not implemented */
6096 if (*(cp2+1) == '[') cp2++;
6098 else if (*cp2 == ']' || *cp2 == '>') {
6099 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6101 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6103 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6104 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6105 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6106 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6107 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6109 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6110 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6114 else if (*cp2 == '-') {
6115 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6116 while (*cp2 == '-') {
6118 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6120 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6121 if (ts) Safefree(rslt); /* filespecs like */
6122 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
6126 else *(cp1++) = *cp2;
6128 else *(cp1++) = *cp2;
6130 while (*cp2) *(cp1++) = *(cp2++);
6133 /* This still leaves /000000/ when working with a
6134 * VMS device root or concealed root.
6140 ulen = strlen(rslt);
6142 /* Get rid of "000000/ in rooted filespecs */
6144 zeros = strstr(rslt, "/000000/");
6145 if (zeros != NULL) {
6147 mlen = ulen - (zeros - rslt) - 7;
6148 memmove(zeros, &zeros[7], mlen);
6157 } /* end of do_tounixspec() */
6159 /* External entry points */
6160 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6161 { return do_tounixspec(spec,buf,0, NULL); }
6162 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6163 { return do_tounixspec(spec,buf,1, NULL); }
6164 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6165 { return do_tounixspec(spec,buf,0, utf8_fl); }
6166 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6167 { return do_tounixspec(spec,buf,1, utf8_fl); }
6169 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6172 This procedure is used to identify if a path is based in either
6173 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6174 it returns the OpenVMS format directory for it.
6176 It is expecting specifications of only '/' or '/xxxx/'
6178 If a posix root does not exist, or 'xxxx' is not a directory
6179 in the posix root, it returns a failure.
6181 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6183 It is used only internally by posix_to_vmsspec_hardway().
6186 static int posix_root_to_vms
6187 (char *vmspath, int vmspath_len,
6188 const char *unixpath,
6189 const int * utf8_fl) {
6191 struct FAB myfab = cc$rms_fab;
6192 struct NAML mynam = cc$rms_naml;
6193 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6194 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6201 unixlen = strlen(unixpath);
6207 #if __CRTL_VER >= 80200000
6208 /* If not a posix spec already, convert it */
6209 if (decc_posix_compliant_pathnames) {
6210 if (strncmp(unixpath,"\"^UP^",5) != 0) {
6211 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6214 /* This is already a VMS specification, no conversion */
6216 strncpy(vmspath,unixpath, vmspath_len);
6225 /* Check to see if this is under the POSIX root */
6226 if (decc_disable_posix_root) {
6230 /* Skip leading / */
6231 if (unixpath[0] == '/') {
6237 strcpy(vmspath,"SYS$POSIX_ROOT:");
6239 /* If this is only the / , or blank, then... */
6240 if (unixpath[0] == '\0') {
6241 /* by definition, this is the answer */
6245 /* Need to look up a directory */
6249 /* Copy and add '^' escape characters as needed */
6252 while (unixpath[i] != 0) {
6255 j += copy_expand_unix_filename_escape
6256 (&vmspath[j], &unixpath[i], &k, utf8_fl);
6260 path_len = strlen(vmspath);
6261 if (vmspath[path_len - 1] == '/')
6263 vmspath[path_len] = ']';
6265 vmspath[path_len] = '\0';
6268 vmspath[vmspath_len] = 0;
6269 if (unixpath[unixlen - 1] == '/')
6271 esa = PerlMem_malloc(VMS_MAXRSS);
6272 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6273 myfab.fab$l_fna = vmspath;
6274 myfab.fab$b_fns = strlen(vmspath);
6275 myfab.fab$l_naml = &mynam;
6276 mynam.naml$l_esa = NULL;
6277 mynam.naml$b_ess = 0;
6278 mynam.naml$l_long_expand = esa;
6279 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6280 mynam.naml$l_rsa = NULL;
6281 mynam.naml$b_rss = 0;
6282 if (decc_efs_case_preserve)
6283 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6284 #ifdef NAML$M_OPEN_SPECIAL
6285 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6288 /* Set up the remaining naml fields */
6289 sts = sys$parse(&myfab);
6291 /* It failed! Try again as a UNIX filespec */
6297 /* get the Device ID and the FID */
6298 sts = sys$search(&myfab);
6299 /* on any failure, returned the POSIX ^UP^ filespec */
6304 specdsc.dsc$a_pointer = vmspath;
6305 specdsc.dsc$w_length = vmspath_len;
6307 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6308 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6309 sts = lib$fid_to_name
6310 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6312 /* on any failure, returned the POSIX ^UP^ filespec */
6314 /* This can happen if user does not have permission to read directories */
6315 if (strncmp(unixpath,"\"^UP^",5) != 0)
6316 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6318 strcpy(vmspath, unixpath);
6321 vmspath[specdsc.dsc$w_length] = 0;
6323 /* Are we expecting a directory? */
6324 if (dir_flag != 0) {
6330 i = specdsc.dsc$w_length - 1;
6334 /* Version must be '1' */
6335 if (vmspath[i--] != '1')
6337 /* Version delimiter is one of ".;" */
6338 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6341 if (vmspath[i--] != 'R')
6343 if (vmspath[i--] != 'I')
6345 if (vmspath[i--] != 'D')
6347 if (vmspath[i--] != '.')
6349 eptr = &vmspath[i+1];
6351 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6352 if (vmspath[i-1] != '^') {
6360 /* Get rid of 6 imaginary zero directory filename */
6361 vmspath[i+1] = '\0';
6365 if (vmspath[i] == '0')
6379 /* /dev/mumble needs to be handled special.
6380 /dev/null becomes NLA0:, And there is the potential for other stuff
6381 like /dev/tty which may need to be mapped to something.
6385 slash_dev_special_to_vms
6386 (const char * unixptr,
6396 nextslash = strchr(unixptr, '/');
6397 len = strlen(unixptr);
6398 if (nextslash != NULL)
6399 len = nextslash - unixptr;
6400 cmp = strncmp("null", unixptr, 5);
6402 if (vmspath_len >= 6) {
6403 strcpy(vmspath, "_NLA0:");
6410 /* The built in routines do not understand perl's special needs, so
6411 doing a manual conversion from UNIX to VMS
6413 If the utf8_fl is not null and points to a non-zero value, then
6414 treat 8 bit characters as UTF-8.
6416 The sequence starting with '$(' and ending with ')' will be passed
6417 through with out interpretation instead of being escaped.
6420 static int posix_to_vmsspec_hardway
6421 (char *vmspath, int vmspath_len,
6422 const char *unixpath,
6427 const char *unixptr;
6428 const char *unixend;
6430 const char *lastslash;
6431 const char *lastdot;
6437 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6438 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6440 if (utf8_fl != NULL)
6446 /* Ignore leading "/" characters */
6447 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6450 unixlen = strlen(unixptr);
6452 /* Do nothing with blank paths */
6459 /* This could have a "^UP^ on the front */
6460 if (strncmp(unixptr,"\"^UP^",5) == 0) {
6466 lastslash = strrchr(unixptr,'/');
6467 lastdot = strrchr(unixptr,'.');
6468 unixend = strrchr(unixptr,'\"');
6469 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6470 unixend = unixptr + unixlen;
6473 /* last dot is last dot or past end of string */
6474 if (lastdot == NULL)
6475 lastdot = unixptr + unixlen;
6477 /* if no directories, set last slash to beginning of string */
6478 if (lastslash == NULL) {
6479 lastslash = unixptr;
6482 /* Watch out for trailing "." after last slash, still a directory */
6483 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6484 lastslash = unixptr + unixlen;
6487 /* Watch out for traiing ".." after last slash, still a directory */
6488 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6489 lastslash = unixptr + unixlen;
6492 /* dots in directories are aways escaped */
6493 if (lastdot < lastslash)
6494 lastdot = unixptr + unixlen;
6497 /* if (unixptr < lastslash) then we are in a directory */
6504 /* Start with the UNIX path */
6505 if (*unixptr != '/') {
6506 /* relative paths */
6508 /* If allowing logical names on relative pathnames, then handle here */
6509 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6510 !decc_posix_compliant_pathnames) {
6516 /* Find the next slash */
6517 nextslash = strchr(unixptr,'/');
6519 esa = PerlMem_malloc(vmspath_len);
6520 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6522 trn = PerlMem_malloc(VMS_MAXRSS);
6523 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6525 if (nextslash != NULL) {
6527 seg_len = nextslash - unixptr;
6528 strncpy(esa, unixptr, seg_len);
6532 strcpy(esa, unixptr);
6533 seg_len = strlen(unixptr);
6535 /* trnlnm(section) */
6536 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6539 /* Now fix up the directory */
6541 /* Split up the path to find the components */
6542 sts = vms_split_path
6561 /* A logical name must be a directory or the full
6562 specification. It is only a full specification if
6563 it is the only component */
6564 if ((unixptr[seg_len] == '\0') ||
6565 (unixptr[seg_len+1] == '\0')) {
6567 /* Is a directory being required? */
6568 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6569 /* Not a logical name */
6574 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6575 /* This must be a directory */
6576 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6577 strcpy(vmsptr, esa);
6578 vmslen=strlen(vmsptr);
6579 vmsptr[vmslen] = ':';
6581 vmsptr[vmslen] = '\0';
6589 /* must be dev/directory - ignore version */
6590 if ((n_len + e_len) != 0)
6593 /* transfer the volume */
6594 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6595 strncpy(vmsptr, v_spec, v_len);
6601 /* unroot the rooted directory */
6602 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6604 r_spec[r_len - 1] = ']';
6606 /* This should not be there, but nothing is perfect */
6608 cmp = strcmp(&r_spec[1], "000000.");
6618 strncpy(vmsptr, r_spec, r_len);
6624 /* Bring over the directory. */
6626 ((d_len + vmslen) < vmspath_len)) {
6628 d_spec[d_len - 1] = ']';
6630 cmp = strcmp(&d_spec[1], "000000.");
6641 /* Remove the redundant root */
6649 strncpy(vmsptr, d_spec, d_len);
6663 if (lastslash > unixptr) {
6666 /* skip leading ./ */
6668 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6674 /* Are we still in a directory? */
6675 if (unixptr <= lastslash) {
6680 /* if not backing up, then it is relative forward. */
6681 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6682 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6690 /* Perl wants an empty directory here to tell the difference
6691 * between a DCL commmand and a filename
6700 /* Handle two special files . and .. */
6701 if (unixptr[0] == '.') {
6702 if (&unixptr[1] == unixend) {
6709 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6720 else { /* Absolute PATH handling */
6724 /* Need to find out where root is */
6726 /* In theory, this procedure should never get an absolute POSIX pathname
6727 * that can not be found on the POSIX root.
6728 * In practice, that can not be relied on, and things will show up
6729 * here that are a VMS device name or concealed logical name instead.
6730 * So to make things work, this procedure must be tolerant.
6732 esa = PerlMem_malloc(vmspath_len);
6733 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6736 nextslash = strchr(&unixptr[1],'/');
6738 if (nextslash != NULL) {
6740 seg_len = nextslash - &unixptr[1];
6741 strncpy(vmspath, unixptr, seg_len + 1);
6742 vmspath[seg_len+1] = 0;
6745 cmp = strncmp(vmspath, "dev", 4);
6747 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6748 if (sts = SS$_NORMAL)
6752 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6755 if ($VMS_STATUS_SUCCESS(sts)) {
6756 /* This is verified to be a real path */
6758 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6759 if ($VMS_STATUS_SUCCESS(sts)) {
6760 strcpy(vmspath, esa);
6761 vmslen = strlen(vmspath);
6762 vmsptr = vmspath + vmslen;
6764 if (unixptr < lastslash) {
6773 cmp = strcmp(rptr,"000000.");
6778 } /* removing 6 zeros */
6779 } /* vmslen < 7, no 6 zeros possible */
6780 } /* Not in a directory */
6781 } /* Posix root found */
6783 /* No posix root, fall back to default directory */
6784 strcpy(vmspath, "SYS$DISK:[");
6785 vmsptr = &vmspath[10];
6787 if (unixptr > lastslash) {
6796 } /* end of verified real path handling */
6801 /* Ok, we have a device or a concealed root that is not in POSIX
6802 * or we have garbage. Make the best of it.
6805 /* Posix to VMS destroyed this, so copy it again */
6806 strncpy(vmspath, &unixptr[1], seg_len);
6807 vmspath[seg_len] = 0;
6809 vmsptr = &vmsptr[vmslen];
6812 /* Now do we need to add the fake 6 zero directory to it? */
6814 if ((*lastslash == '/') && (nextslash < lastslash)) {
6815 /* No there is another directory */
6822 /* now we have foo:bar or foo:[000000]bar to decide from */
6823 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6825 if (!islnm && !decc_posix_compliant_pathnames) {
6827 cmp = strncmp("bin", vmspath, 4);
6829 /* bin => SYS$SYSTEM: */
6830 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6833 /* tmp => SYS$SCRATCH: */
6834 cmp = strncmp("tmp", vmspath, 4);
6836 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6841 trnend = islnm ? islnm - 1 : 0;
6843 /* if this was a logical name, ']' or '>' must be present */
6844 /* if not a logical name, then assume a device and hope. */
6845 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6847 /* if log name and trailing '.' then rooted - treat as device */
6848 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6850 /* Fix me, if not a logical name, a device lookup should be
6851 * done to see if the device is file structured. If the device
6852 * is not file structured, the 6 zeros should not be put on.
6854 * As it is, perl is occasionally looking for dev:[000000]tty.
6855 * which looks a little strange.
6857 * Not that easy to detect as "/dev" may be file structured with
6858 * special device files.
6861 if ((add_6zero == 0) && (*nextslash == '/') &&
6862 (&nextslash[1] == unixend)) {
6863 /* No real directory present */
6868 /* Put the device delimiter on */
6871 unixptr = nextslash;
6874 /* Start directory if needed */
6875 if (!islnm || add_6zero) {
6881 /* add fake 000000] if needed */
6894 } /* non-POSIX translation */
6896 } /* End of relative/absolute path handling */
6898 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6905 if (dir_start != 0) {
6907 /* First characters in a directory are handled special */
6908 while ((*unixptr == '/') ||
6909 ((*unixptr == '.') &&
6910 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6911 (&unixptr[1]==unixend)))) {
6916 /* Skip redundant / in specification */
6917 while ((*unixptr == '/') && (dir_start != 0)) {
6920 if (unixptr == lastslash)
6923 if (unixptr == lastslash)
6926 /* Skip redundant ./ characters */
6927 while ((*unixptr == '.') &&
6928 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6931 if (unixptr == lastslash)
6933 if (*unixptr == '/')
6936 if (unixptr == lastslash)
6939 /* Skip redundant ../ characters */
6940 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6941 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6942 /* Set the backing up flag */
6948 unixptr++; /* first . */
6949 unixptr++; /* second . */
6950 if (unixptr == lastslash)
6952 if (*unixptr == '/') /* The slash */
6955 if (unixptr == lastslash)
6958 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6959 /* Not needed when VMS is pretending to be UNIX. */
6961 /* Is this loop stuck because of too many dots? */
6962 if (loop_flag == 0) {
6963 /* Exit the loop and pass the rest through */
6968 /* Are we done with directories yet? */
6969 if (unixptr >= lastslash) {
6971 /* Watch out for trailing dots */
6980 if (*unixptr == '/')
6984 /* Have we stopped backing up? */
6989 /* dir_start continues to be = 1 */
6991 if (*unixptr == '-') {
6993 *vmsptr++ = *unixptr++;
6997 /* Now are we done with directories yet? */
6998 if (unixptr >= lastslash) {
7000 /* Watch out for trailing dots */
7016 if (unixptr >= unixend)
7019 /* Normal characters - More EFS work probably needed */
7025 /* remove multiple / */
7026 while (unixptr[1] == '/') {
7029 if (unixptr == lastslash) {
7030 /* Watch out for trailing dots */
7042 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7043 /* Not needed when VMS is pretending to be UNIX. */
7047 if (unixptr != unixend)
7052 if ((unixptr < lastdot) || (unixptr < lastslash) ||
7053 (&unixptr[1] == unixend)) {
7059 /* trailing dot ==> '^..' on VMS */
7060 if (unixptr == unixend) {
7068 *vmsptr++ = *unixptr++;
7072 if (quoted && (&unixptr[1] == unixend)) {
7076 in_cnt = copy_expand_unix_filename_escape
7077 (vmsptr, unixptr, &out_cnt, utf8_fl);
7087 in_cnt = copy_expand_unix_filename_escape
7088 (vmsptr, unixptr, &out_cnt, utf8_fl);
7095 /* Make sure directory is closed */
7096 if (unixptr == lastslash) {
7098 vmsptr2 = vmsptr - 1;
7100 if (*vmsptr2 != ']') {
7103 /* directories do not end in a dot bracket */
7104 if (*vmsptr2 == '.') {
7108 if (*vmsptr2 != '^') {
7109 vmsptr--; /* back up over the dot */
7117 /* Add a trailing dot if a file with no extension */
7118 vmsptr2 = vmsptr - 1;
7120 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7121 (*vmsptr2 != ')') && (*lastdot != '.')) {
7132 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7133 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7138 /* If a UTF8 flag is being passed, honor it */
7140 if (utf8_fl != NULL) {
7141 utf8_flag = *utf8_fl;
7146 /* If there is a possibility of UTF8, then if any UTF8 characters
7147 are present, then they must be converted to VTF-7
7149 result = strcpy(rslt, path); /* FIX-ME */
7152 result = strcpy(rslt, path);
7158 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7159 static char *mp_do_tovmsspec
7160 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7161 static char __tovmsspec_retbuf[VMS_MAXRSS];
7162 char *rslt, *dirend;
7167 unsigned long int infront = 0, hasdir = 1;
7170 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7171 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7173 if (path == NULL) return NULL;
7174 rslt_len = VMS_MAXRSS-1;
7175 if (buf) rslt = buf;
7176 else if (ts) Newx(rslt, VMS_MAXRSS, char);
7177 else rslt = __tovmsspec_retbuf;
7179 /* '.' and '..' are "[]" and "[-]" for a quick check */
7180 if (path[0] == '.') {
7181 if (path[1] == '\0') {
7183 if (utf8_flag != NULL)
7188 if (path[1] == '.' && path[2] == '\0') {
7190 if (utf8_flag != NULL)
7197 /* Posix specifications are now a native VMS format */
7198 /*--------------------------------------------------*/
7199 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7200 if (decc_posix_compliant_pathnames) {
7201 if (strncmp(path,"\"^UP^",5) == 0) {
7202 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7208 /* This is really the only way to see if this is already in VMS format */
7209 sts = vms_split_path
7224 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7225 replacement, because the above parse just took care of most of
7226 what is needed to do vmspath when the specification is already
7229 And if it is not already, it is easier to do the conversion as
7230 part of this routine than to call this routine and then work on
7234 /* If VMS punctuation was found, it is already VMS format */
7235 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7236 if (utf8_flag != NULL)
7241 /* Now, what to do with trailing "." cases where there is no
7242 extension? If this is a UNIX specification, and EFS characters
7243 are enabled, then the trailing "." should be converted to a "^.".
7244 But if this was already a VMS specification, then it should be
7247 So in the case of ambiguity, leave the specification alone.
7251 /* If there is a possibility of UTF8, then if any UTF8 characters
7252 are present, then they must be converted to VTF-7
7254 if (utf8_flag != NULL)
7260 dirend = strrchr(path,'/');
7262 if (dirend == NULL) {
7263 /* If we get here with no UNIX directory delimiters, then this is
7264 not a complete file specification, either garbage a UNIX glob
7265 specification that can not be converted to a VMS wildcard, or
7266 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7267 so apparently other programs expect this also.
7269 utf8 flag setting needs to be preserved.
7275 /* If POSIX mode active, handle the conversion */
7276 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7277 if (decc_efs_charset) {
7278 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7283 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
7284 if (!*(dirend+2)) dirend +=2;
7285 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7286 if (decc_efs_charset == 0) {
7287 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7293 lastdot = strrchr(cp2,'.');
7299 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7301 if (decc_disable_posix_root) {
7302 strcpy(rslt,"sys$disk:[000000]");
7305 strcpy(rslt,"sys$posix_root:[000000]");
7307 if (utf8_flag != NULL)
7311 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7313 trndev = PerlMem_malloc(VMS_MAXRSS);
7314 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7315 islnm = my_trnlnm(rslt,trndev,0);
7317 /* DECC special handling */
7319 if (strcmp(rslt,"bin") == 0) {
7320 strcpy(rslt,"sys$system");
7323 islnm = my_trnlnm(rslt,trndev,0);
7325 else if (strcmp(rslt,"tmp") == 0) {
7326 strcpy(rslt,"sys$scratch");
7329 islnm = my_trnlnm(rslt,trndev,0);
7331 else if (!decc_disable_posix_root) {
7332 strcpy(rslt, "sys$posix_root");
7336 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7337 islnm = my_trnlnm(rslt,trndev,0);
7339 else if (strcmp(rslt,"dev") == 0) {
7340 if (strncmp(cp2,"/null", 5) == 0) {
7341 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7342 strcpy(rslt,"NLA0");
7346 islnm = my_trnlnm(rslt,trndev,0);
7352 trnend = islnm ? strlen(trndev) - 1 : 0;
7353 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7354 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7355 /* If the first element of the path is a logical name, determine
7356 * whether it has to be translated so we can add more directories. */
7357 if (!islnm || rooted) {
7360 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7364 if (cp2 != dirend) {
7365 strcpy(rslt,trndev);
7366 cp1 = rslt + trnend;
7373 if (decc_disable_posix_root) {
7379 PerlMem_free(trndev);
7384 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7385 cp2 += 2; /* skip over "./" - it's redundant */
7386 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
7388 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7389 *(cp1++) = '-'; /* "../" --> "-" */
7392 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7393 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7394 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7395 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7398 else if ((cp2 != lastdot) || (lastdot < dirend)) {
7399 /* Escape the extra dots in EFS file specifications */
7402 if (cp2 > dirend) cp2 = dirend;
7404 else *(cp1++) = '.';
7406 for (; cp2 < dirend; cp2++) {
7408 if (*(cp2-1) == '/') continue;
7409 if (*(cp1-1) != '.') *(cp1++) = '.';
7412 else if (!infront && *cp2 == '.') {
7413 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7414 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
7415 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7416 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7417 else if (*(cp1-2) == '[') *(cp1-1) = '-';
7418 else { /* back up over previous directory name */
7420 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7421 if (*(cp1-1) == '[') {
7422 memcpy(cp1,"000000.",7);
7427 if (cp2 == dirend) break;
7429 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7430 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7431 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7432 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7434 *(cp1++) = '.'; /* Simulate trailing '/' */
7435 cp2 += 2; /* for loop will incr this to == dirend */
7437 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
7440 if (decc_efs_charset == 0)
7441 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
7443 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
7449 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
7451 if (decc_efs_charset == 0)
7458 else *(cp1++) = *cp2;
7462 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7463 if (hasdir) *(cp1++) = ']';
7464 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
7465 /* fixme for ODS5 */
7472 if (decc_efs_charset == 0)
7483 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7484 decc_readdir_dropdotnotype) {
7489 /* trailing dot ==> '^..' on VMS */
7496 *(cp1++) = *(cp2++);
7501 /* This could be a macro to be passed through */
7502 *(cp1++) = *(cp2++);
7504 const char * save_cp2;
7508 /* paranoid check */
7514 *(cp1++) = *(cp2++);
7515 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7516 *(cp1++) = *(cp2++);
7517 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7518 *(cp1++) = *(cp2++);
7521 *(cp1++) = *(cp2++);
7525 if (is_macro == 0) {
7526 /* Not really a macro - never mind */
7556 *(cp1++) = *(cp2++);
7559 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7560 * which is wrong. UNIX notation should be ".dir." unless
7561 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7562 * changing this behavior could break more things at this time.
7563 * efs character set effectively does not allow "." to be a version
7564 * delimiter as a further complication about changing this.
7566 if (decc_filename_unix_report != 0) {
7569 *(cp1++) = *(cp2++);
7572 *(cp1++) = *(cp2++);
7575 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7579 /* Fix me for "^]", but that requires making sure that you do
7580 * not back up past the start of the filename
7582 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7587 if (utf8_flag != NULL)
7591 } /* end of do_tovmsspec() */
7593 /* External entry points */
7594 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7595 { return do_tovmsspec(path,buf,0,NULL); }
7596 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7597 { return do_tovmsspec(path,buf,1,NULL); }
7598 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7599 { return do_tovmsspec(path,buf,0,utf8_fl); }
7600 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7601 { return do_tovmsspec(path,buf,1,utf8_fl); }
7603 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7604 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7605 static char __tovmspath_retbuf[VMS_MAXRSS];
7607 char *pathified, *vmsified, *cp;
7609 if (path == NULL) return NULL;
7610 pathified = PerlMem_malloc(VMS_MAXRSS);
7611 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7612 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7613 PerlMem_free(pathified);
7619 Newx(vmsified, VMS_MAXRSS, char);
7620 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7621 PerlMem_free(pathified);
7622 if (vmsified) Safefree(vmsified);
7625 PerlMem_free(pathified);
7630 vmslen = strlen(vmsified);
7631 Newx(cp,vmslen+1,char);
7632 memcpy(cp,vmsified,vmslen);
7638 strcpy(__tovmspath_retbuf,vmsified);
7640 return __tovmspath_retbuf;
7643 } /* end of do_tovmspath() */
7645 /* External entry points */
7646 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7647 { return do_tovmspath(path,buf,0, NULL); }
7648 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7649 { return do_tovmspath(path,buf,1, NULL); }
7650 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7651 { return do_tovmspath(path,buf,0,utf8_fl); }
7652 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7653 { return do_tovmspath(path,buf,1,utf8_fl); }
7656 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7657 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7658 static char __tounixpath_retbuf[VMS_MAXRSS];
7660 char *pathified, *unixified, *cp;
7662 if (path == NULL) return NULL;
7663 pathified = PerlMem_malloc(VMS_MAXRSS);
7664 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7665 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7666 PerlMem_free(pathified);
7672 Newx(unixified, VMS_MAXRSS, char);
7674 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7675 PerlMem_free(pathified);
7676 if (unixified) Safefree(unixified);
7679 PerlMem_free(pathified);
7684 unixlen = strlen(unixified);
7685 Newx(cp,unixlen+1,char);
7686 memcpy(cp,unixified,unixlen);
7688 Safefree(unixified);
7692 strcpy(__tounixpath_retbuf,unixified);
7693 Safefree(unixified);
7694 return __tounixpath_retbuf;
7697 } /* end of do_tounixpath() */
7699 /* External entry points */
7700 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7701 { return do_tounixpath(path,buf,0,NULL); }
7702 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7703 { return do_tounixpath(path,buf,1,NULL); }
7704 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7705 { return do_tounixpath(path,buf,0,utf8_fl); }
7706 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7707 { return do_tounixpath(path,buf,1,utf8_fl); }
7710 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
7712 *****************************************************************************
7714 * Copyright (C) 1989-1994 by *
7715 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
7717 * Permission is hereby granted for the reproduction of this software, *
7718 * on condition that this copyright notice is included in the reproduction, *
7719 * and that such reproduction is not for purposes of profit or material *
7722 * 27-Aug-1994 Modified for inclusion in perl5 *
7723 * by Charles Bailey bailey@newman.upenn.edu *
7724 *****************************************************************************
7728 * getredirection() is intended to aid in porting C programs
7729 * to VMS (Vax-11 C). The native VMS environment does not support
7730 * '>' and '<' I/O redirection, or command line wild card expansion,
7731 * or a command line pipe mechanism using the '|' AND background
7732 * command execution '&'. All of these capabilities are provided to any
7733 * C program which calls this procedure as the first thing in the
7735 * The piping mechanism will probably work with almost any 'filter' type
7736 * of program. With suitable modification, it may useful for other
7737 * portability problems as well.
7739 * Author: Mark Pizzolato mark@infocomm.com
7743 struct list_item *next;
7747 static void add_item(struct list_item **head,
7748 struct list_item **tail,
7752 static void mp_expand_wild_cards(pTHX_ char *item,
7753 struct list_item **head,
7754 struct list_item **tail,
7757 static int background_process(pTHX_ int argc, char **argv);
7759 static void pipe_and_fork(pTHX_ char **cmargv);
7761 /*{{{ void getredirection(int *ac, char ***av)*/
7763 mp_getredirection(pTHX_ int *ac, char ***av)
7765 * Process vms redirection arg's. Exit if any error is seen.
7766 * If getredirection() processes an argument, it is erased
7767 * from the vector. getredirection() returns a new argc and argv value.
7768 * In the event that a background command is requested (by a trailing "&"),
7769 * this routine creates a background subprocess, and simply exits the program.
7771 * Warning: do not try to simplify the code for vms. The code
7772 * presupposes that getredirection() is called before any data is
7773 * read from stdin or written to stdout.
7775 * Normal usage is as follows:
7781 * getredirection(&argc, &argv);
7785 int argc = *ac; /* Argument Count */
7786 char **argv = *av; /* Argument Vector */
7787 char *ap; /* Argument pointer */
7788 int j; /* argv[] index */
7789 int item_count = 0; /* Count of Items in List */
7790 struct list_item *list_head = 0; /* First Item in List */
7791 struct list_item *list_tail; /* Last Item in List */
7792 char *in = NULL; /* Input File Name */
7793 char *out = NULL; /* Output File Name */
7794 char *outmode = "w"; /* Mode to Open Output File */
7795 char *err = NULL; /* Error File Name */
7796 char *errmode = "w"; /* Mode to Open Error File */
7797 int cmargc = 0; /* Piped Command Arg Count */
7798 char **cmargv = NULL;/* Piped Command Arg Vector */
7801 * First handle the case where the last thing on the line ends with
7802 * a '&'. This indicates the desire for the command to be run in a
7803 * subprocess, so we satisfy that desire.
7806 if (0 == strcmp("&", ap))
7807 exit(background_process(aTHX_ --argc, argv));
7808 if (*ap && '&' == ap[strlen(ap)-1])
7810 ap[strlen(ap)-1] = '\0';
7811 exit(background_process(aTHX_ argc, argv));
7814 * Now we handle the general redirection cases that involve '>', '>>',
7815 * '<', and pipes '|'.
7817 for (j = 0; j < argc; ++j)
7819 if (0 == strcmp("<", argv[j]))
7823 fprintf(stderr,"No input file after < on command line");
7824 exit(LIB$_WRONUMARG);
7829 if ('<' == *(ap = argv[j]))
7834 if (0 == strcmp(">", ap))
7838 fprintf(stderr,"No output file after > on command line");
7839 exit(LIB$_WRONUMARG);
7858 fprintf(stderr,"No output file after > or >> on command line");
7859 exit(LIB$_WRONUMARG);
7863 if (('2' == *ap) && ('>' == ap[1]))
7880 fprintf(stderr,"No output file after 2> or 2>> on command line");
7881 exit(LIB$_WRONUMARG);
7885 if (0 == strcmp("|", argv[j]))
7889 fprintf(stderr,"No command into which to pipe on command line");
7890 exit(LIB$_WRONUMARG);
7892 cmargc = argc-(j+1);
7893 cmargv = &argv[j+1];
7897 if ('|' == *(ap = argv[j]))
7905 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7908 * Allocate and fill in the new argument vector, Some Unix's terminate
7909 * the list with an extra null pointer.
7911 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7912 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7914 for (j = 0; j < item_count; ++j, list_head = list_head->next)
7915 argv[j] = list_head->value;
7921 fprintf(stderr,"'|' and '>' may not both be specified on command line");
7922 exit(LIB$_INVARGORD);
7924 pipe_and_fork(aTHX_ cmargv);
7927 /* Check for input from a pipe (mailbox) */
7929 if (in == NULL && 1 == isapipe(0))
7931 char mbxname[L_tmpnam];
7933 long int dvi_item = DVI$_DEVBUFSIZ;
7934 $DESCRIPTOR(mbxnam, "");
7935 $DESCRIPTOR(mbxdevnam, "");
7937 /* Input from a pipe, reopen it in binary mode to disable */
7938 /* carriage control processing. */
7940 fgetname(stdin, mbxname);
7941 mbxnam.dsc$a_pointer = mbxname;
7942 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7943 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7944 mbxdevnam.dsc$a_pointer = mbxname;
7945 mbxdevnam.dsc$w_length = sizeof(mbxname);
7946 dvi_item = DVI$_DEVNAM;
7947 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7948 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7951 freopen(mbxname, "rb", stdin);
7954 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7958 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7960 fprintf(stderr,"Can't open input file %s as stdin",in);
7963 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7965 fprintf(stderr,"Can't open output file %s as stdout",out);
7968 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7971 if (strcmp(err,"&1") == 0) {
7972 dup2(fileno(stdout), fileno(stderr));
7973 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7976 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7978 fprintf(stderr,"Can't open error file %s as stderr",err);
7982 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7986 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7989 #ifdef ARGPROC_DEBUG
7990 PerlIO_printf(Perl_debug_log, "Arglist:\n");
7991 for (j = 0; j < *ac; ++j)
7992 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7994 /* Clear errors we may have hit expanding wildcards, so they don't
7995 show up in Perl's $! later */
7996 set_errno(0); set_vaxc_errno(1);
7997 } /* end of getredirection() */
8000 static void add_item(struct list_item **head,
8001 struct list_item **tail,
8007 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8008 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8012 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8013 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8014 *tail = (*tail)->next;
8016 (*tail)->value = value;
8020 static void mp_expand_wild_cards(pTHX_ char *item,
8021 struct list_item **head,
8022 struct list_item **tail,
8026 unsigned long int context = 0;
8034 $DESCRIPTOR(filespec, "");
8035 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8036 $DESCRIPTOR(resultspec, "");
8037 unsigned long int lff_flags = 0;
8041 #ifdef VMS_LONGNAME_SUPPORT
8042 lff_flags = LIB$M_FIL_LONG_NAMES;
8045 for (cp = item; *cp; cp++) {
8046 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8047 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8049 if (!*cp || isspace(*cp))
8051 add_item(head, tail, item, count);
8056 /* "double quoted" wild card expressions pass as is */
8057 /* From DCL that means using e.g.: */
8058 /* perl program """perl.*""" */
8059 item_len = strlen(item);
8060 if ( '"' == *item && '"' == item[item_len-1] )
8063 item[item_len-2] = '\0';
8064 add_item(head, tail, item, count);
8068 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8069 resultspec.dsc$b_class = DSC$K_CLASS_D;
8070 resultspec.dsc$a_pointer = NULL;
8071 vmsspec = PerlMem_malloc(VMS_MAXRSS);
8072 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8073 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8074 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8075 if (!isunix || !filespec.dsc$a_pointer)
8076 filespec.dsc$a_pointer = item;
8077 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8079 * Only return version specs, if the caller specified a version
8081 had_version = strchr(item, ';');
8083 * Only return device and directory specs, if the caller specifed either.
8085 had_device = strchr(item, ':');
8086 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8088 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8089 (&filespec, &resultspec, &context,
8090 &defaultspec, 0, &rms_sts, &lff_flags)))
8095 string = PerlMem_malloc(resultspec.dsc$w_length+1);
8096 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8097 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8098 string[resultspec.dsc$w_length] = '\0';
8099 if (NULL == had_version)
8100 *(strrchr(string, ';')) = '\0';
8101 if ((!had_directory) && (had_device == NULL))
8103 if (NULL == (devdir = strrchr(string, ']')))
8104 devdir = strrchr(string, '>');
8105 strcpy(string, devdir + 1);
8108 * Be consistent with what the C RTL has already done to the rest of
8109 * the argv items and lowercase all of these names.
8111 if (!decc_efs_case_preserve) {
8112 for (c = string; *c; ++c)
8116 if (isunix) trim_unixpath(string,item,1);
8117 add_item(head, tail, string, count);
8120 PerlMem_free(vmsspec);
8121 if (sts != RMS$_NMF)
8123 set_vaxc_errno(sts);
8126 case RMS$_FNF: case RMS$_DNF:
8127 set_errno(ENOENT); break;
8129 set_errno(ENOTDIR); break;
8131 set_errno(ENODEV); break;
8132 case RMS$_FNM: case RMS$_SYN:
8133 set_errno(EINVAL); break;
8135 set_errno(EACCES); break;
8137 _ckvmssts_noperl(sts);
8141 add_item(head, tail, item, count);
8142 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8143 _ckvmssts_noperl(lib$find_file_end(&context));
8146 static int child_st[2];/* Event Flag set when child process completes */
8148 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
8150 static unsigned long int exit_handler(int *status)
8154 if (0 == child_st[0])
8156 #ifdef ARGPROC_DEBUG
8157 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8159 fflush(stdout); /* Have to flush pipe for binary data to */
8160 /* terminate properly -- <tp@mccall.com> */
8161 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8162 sys$dassgn(child_chan);
8164 sys$synch(0, child_st);
8169 static void sig_child(int chan)
8171 #ifdef ARGPROC_DEBUG
8172 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8174 if (child_st[0] == 0)
8178 static struct exit_control_block exit_block =
8183 &exit_block.exit_status,
8188 pipe_and_fork(pTHX_ char **cmargv)
8191 struct dsc$descriptor_s *vmscmd;
8192 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8193 int sts, j, l, ismcr, quote, tquote = 0;
8195 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
8196 vms_execfree(vmscmd);
8201 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
8202 && toupper(*(q+2)) == 'R' && !*(q+3);
8204 while (q && l < MAX_DCL_LINE_LENGTH) {
8206 if (j > 0 && quote) {
8212 if (ismcr && j > 1) quote = 1;
8213 tquote = (strchr(q,' ')) != NULL || *q == '\0';
8216 if (quote || tquote) {
8222 if ((quote||tquote) && *q == '"') {
8232 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8234 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8238 static int background_process(pTHX_ int argc, char **argv)
8240 char command[MAX_DCL_SYMBOL + 1] = "$";
8241 $DESCRIPTOR(value, "");
8242 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8243 static $DESCRIPTOR(null, "NLA0:");
8244 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8246 $DESCRIPTOR(pidstr, "");
8248 unsigned long int flags = 17, one = 1, retsts;
8251 strcat(command, argv[0]);
8252 len = strlen(command);
8253 while (--argc && (len < MAX_DCL_SYMBOL))
8255 strcat(command, " \"");
8256 strcat(command, *(++argv));
8257 strcat(command, "\"");
8258 len = strlen(command);
8260 value.dsc$a_pointer = command;
8261 value.dsc$w_length = strlen(value.dsc$a_pointer);
8262 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8263 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8264 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8265 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8268 _ckvmssts_noperl(retsts);
8270 #ifdef ARGPROC_DEBUG
8271 PerlIO_printf(Perl_debug_log, "%s\n", command);
8273 sprintf(pidstring, "%08X", pid);
8274 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8275 pidstr.dsc$a_pointer = pidstring;
8276 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8277 lib$set_symbol(&pidsymbol, &pidstr);
8281 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8284 /* OS-specific initialization at image activation (not thread startup) */
8285 /* Older VAXC header files lack these constants */
8286 #ifndef JPI$_RIGHTS_SIZE
8287 # define JPI$_RIGHTS_SIZE 817
8289 #ifndef KGB$M_SUBSYSTEM
8290 # define KGB$M_SUBSYSTEM 0x8
8293 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8295 /*{{{void vms_image_init(int *, char ***)*/
8297 vms_image_init(int *argcp, char ***argvp)
8299 char eqv[LNM$C_NAMLENGTH+1] = "";
8300 unsigned int len, tabct = 8, tabidx = 0;
8301 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8302 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8303 unsigned short int dummy, rlen;
8304 struct dsc$descriptor_s **tabvec;
8305 #if defined(PERL_IMPLICIT_CONTEXT)
8308 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8309 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8310 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8313 #ifdef KILL_BY_SIGPRC
8314 Perl_csighandler_init();
8317 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8318 _ckvmssts_noperl(iosb[0]);
8319 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8320 if (iprv[i]) { /* Running image installed with privs? */
8321 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
8326 /* Rights identifiers might trigger tainting as well. */
8327 if (!will_taint && (rlen || rsz)) {
8328 while (rlen < rsz) {
8329 /* We didn't get all the identifiers on the first pass. Allocate a
8330 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8331 * were needed to hold all identifiers at time of last call; we'll
8332 * allocate that many unsigned long ints), and go back and get 'em.
8333 * If it gave us less than it wanted to despite ample buffer space,
8334 * something's broken. Is your system missing a system identifier?
8336 if (rsz <= jpilist[1].buflen) {
8337 /* Perl_croak accvios when used this early in startup. */
8338 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8339 rsz, (unsigned long) jpilist[1].buflen,
8340 "Check your rights database for corruption.\n");
8343 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8344 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8345 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8346 jpilist[1].buflen = rsz * sizeof(unsigned long int);
8347 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8348 _ckvmssts_noperl(iosb[0]);
8350 mask = jpilist[1].bufadr;
8351 /* Check attribute flags for each identifier (2nd longword); protected
8352 * subsystem identifiers trigger tainting.
8354 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8355 if (mask[i] & KGB$M_SUBSYSTEM) {
8360 if (mask != rlst) PerlMem_free(mask);
8363 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8364 * logical, some versions of the CRTL will add a phanthom /000000/
8365 * directory. This needs to be removed.
8367 if (decc_filename_unix_report) {
8370 ulen = strlen(argvp[0][0]);
8372 zeros = strstr(argvp[0][0], "/000000/");
8373 if (zeros != NULL) {
8375 mlen = ulen - (zeros - argvp[0][0]) - 7;
8376 memmove(zeros, &zeros[7], mlen);
8378 argvp[0][0][ulen] = '\0';
8381 /* It also may have a trailing dot that needs to be removed otherwise
8382 * it will be converted to VMS mode incorrectly.
8385 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8386 argvp[0][0][ulen] = '\0';
8389 /* We need to use this hack to tell Perl it should run with tainting,
8390 * since its tainting flag may be part of the PL_curinterp struct, which
8391 * hasn't been allocated when vms_image_init() is called.
8394 char **newargv, **oldargv;
8396 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8397 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8398 newargv[0] = oldargv[0];
8399 newargv[1] = PerlMem_malloc(3 * sizeof(char));
8400 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8401 strcpy(newargv[1], "-T");
8402 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8404 newargv[*argcp] = NULL;
8405 /* We orphan the old argv, since we don't know where it's come from,
8406 * so we don't know how to free it.
8410 else { /* Did user explicitly request tainting? */
8412 char *cp, **av = *argvp;
8413 for (i = 1; i < *argcp; i++) {
8414 if (*av[i] != '-') break;
8415 for (cp = av[i]+1; *cp; cp++) {
8416 if (*cp == 'T') { will_taint = 1; break; }
8417 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8418 strchr("DFIiMmx",*cp)) break;
8420 if (will_taint) break;
8425 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8428 tabvec = (struct dsc$descriptor_s **)
8429 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8430 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8432 else if (tabidx >= tabct) {
8434 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8435 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8437 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8438 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8439 tabvec[tabidx]->dsc$w_length = 0;
8440 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
8441 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
8442 tabvec[tabidx]->dsc$a_pointer = NULL;
8443 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8445 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8447 getredirection(argcp,argvp);
8448 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8450 # include <reentrancy.h>
8451 decc$set_reentrancy(C$C_MULTITHREAD);
8460 * Trim Unix-style prefix off filespec, so it looks like what a shell
8461 * glob expansion would return (i.e. from specified prefix on, not
8462 * full path). Note that returned filespec is Unix-style, regardless
8463 * of whether input filespec was VMS-style or Unix-style.
8465 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8466 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
8467 * vector of options; at present, only bit 0 is used, and if set tells
8468 * trim unixpath to try the current default directory as a prefix when
8469 * presented with a possibly ambiguous ... wildcard.
8471 * Returns !=0 on success, with trimmed filespec replacing contents of
8472 * fspec, and 0 on failure, with contents of fpsec unchanged.
8474 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8476 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8478 char *unixified, *unixwild,
8479 *template, *base, *end, *cp1, *cp2;
8480 register int tmplen, reslen = 0, dirs = 0;
8482 unixwild = PerlMem_malloc(VMS_MAXRSS);
8483 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8484 if (!wildspec || !fspec) return 0;
8485 template = unixwild;
8486 if (strpbrk(wildspec,"]>:") != NULL) {
8487 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8488 PerlMem_free(unixwild);
8493 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8494 unixwild[VMS_MAXRSS-1] = 0;
8496 unixified = PerlMem_malloc(VMS_MAXRSS);
8497 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8498 if (strpbrk(fspec,"]>:") != NULL) {
8499 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8500 PerlMem_free(unixwild);
8501 PerlMem_free(unixified);
8504 else base = unixified;
8505 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8506 * check to see that final result fits into (isn't longer than) fspec */
8507 reslen = strlen(fspec);
8511 /* No prefix or absolute path on wildcard, so nothing to remove */
8512 if (!*template || *template == '/') {
8513 PerlMem_free(unixwild);
8514 if (base == fspec) {
8515 PerlMem_free(unixified);
8518 tmplen = strlen(unixified);
8519 if (tmplen > reslen) {
8520 PerlMem_free(unixified);
8521 return 0; /* not enough space */
8523 /* Copy unixified resultant, including trailing NUL */
8524 memmove(fspec,unixified,tmplen+1);
8525 PerlMem_free(unixified);
8529 for (end = base; *end; end++) ; /* Find end of resultant filespec */
8530 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8531 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8532 for (cp1 = end ;cp1 >= base; cp1--)
8533 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8535 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8536 PerlMem_free(unixified);
8537 PerlMem_free(unixwild);
8542 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8543 int ells = 1, totells, segdirs, match;
8544 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8545 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8547 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8549 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8550 tpl = PerlMem_malloc(VMS_MAXRSS);
8551 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8552 if (ellipsis == template && opts & 1) {
8553 /* Template begins with an ellipsis. Since we can't tell how many
8554 * directory names at the front of the resultant to keep for an
8555 * arbitrary starting point, we arbitrarily choose the current
8556 * default directory as a starting point. If it's there as a prefix,
8557 * clip it off. If not, fall through and act as if the leading
8558 * ellipsis weren't there (i.e. return shortest possible path that
8559 * could match template).
8561 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8563 PerlMem_free(unixified);
8564 PerlMem_free(unixwild);
8567 if (!decc_efs_case_preserve) {
8568 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8569 if (_tolower(*cp1) != _tolower(*cp2)) break;
8571 segdirs = dirs - totells; /* Min # of dirs we must have left */
8572 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8573 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8574 memmove(fspec,cp2+1,end - cp2);
8576 PerlMem_free(unixified);
8577 PerlMem_free(unixwild);
8581 /* First off, back up over constant elements at end of path */
8583 for (front = end ; front >= base; front--)
8584 if (*front == '/' && !dirs--) { front++; break; }
8586 lcres = PerlMem_malloc(VMS_MAXRSS);
8587 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8588 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8590 if (!decc_efs_case_preserve) {
8591 *cp2 = _tolower(*cp1); /* Make lc copy for match */
8599 PerlMem_free(unixified);
8600 PerlMem_free(unixwild);
8601 PerlMem_free(lcres);
8602 return 0; /* Path too long. */
8605 *cp2 = '\0'; /* Pick up with memcpy later */
8606 lcfront = lcres + (front - base);
8607 /* Now skip over each ellipsis and try to match the path in front of it. */
8609 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8610 if (*(cp1) == '.' && *(cp1+1) == '.' &&
8611 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
8612 if (cp1 < template) break; /* template started with an ellipsis */
8613 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8614 ellipsis = cp1; continue;
8616 wilddsc.dsc$a_pointer = tpl;
8617 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8619 for (segdirs = 0, cp2 = tpl;
8620 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8622 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8624 if (!decc_efs_case_preserve) {
8625 *cp2 = _tolower(*cp1); /* else lowercase for match */
8628 *cp2 = *cp1; /* else preserve case for match */
8631 if (*cp2 == '/') segdirs++;
8633 if (cp1 != ellipsis - 1) {
8635 PerlMem_free(unixified);
8636 PerlMem_free(unixwild);
8637 PerlMem_free(lcres);
8638 return 0; /* Path too long */
8640 /* Back up at least as many dirs as in template before matching */
8641 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8642 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8643 for (match = 0; cp1 > lcres;) {
8644 resdsc.dsc$a_pointer = cp1;
8645 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8647 if (match == 1) lcfront = cp1;
8649 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8653 PerlMem_free(unixified);
8654 PerlMem_free(unixwild);
8655 PerlMem_free(lcres);
8656 return 0; /* Can't find prefix ??? */
8658 if (match > 1 && opts & 1) {
8659 /* This ... wildcard could cover more than one set of dirs (i.e.
8660 * a set of similar dir names is repeated). If the template
8661 * contains more than 1 ..., upstream elements could resolve the
8662 * ambiguity, but it's not worth a full backtracking setup here.
8663 * As a quick heuristic, clip off the current default directory
8664 * if it's present to find the trimmed spec, else use the
8665 * shortest string that this ... could cover.
8667 char def[NAM$C_MAXRSS+1], *st;
8669 if (getcwd(def, sizeof def,0) == NULL) {
8670 Safefree(unixified);
8676 if (!decc_efs_case_preserve) {
8677 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8678 if (_tolower(*cp1) != _tolower(*cp2)) break;
8680 segdirs = dirs - totells; /* Min # of dirs we must have left */
8681 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8682 if (*cp1 == '\0' && *cp2 == '/') {
8683 memmove(fspec,cp2+1,end - cp2);
8685 PerlMem_free(unixified);
8686 PerlMem_free(unixwild);
8687 PerlMem_free(lcres);
8690 /* Nope -- stick with lcfront from above and keep going. */
8693 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8695 PerlMem_free(unixified);
8696 PerlMem_free(unixwild);
8697 PerlMem_free(lcres);
8702 } /* end of trim_unixpath() */
8707 * VMS readdir() routines.
8708 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8710 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
8711 * Minor modifications to original routines.
8714 /* readdir may have been redefined by reentr.h, so make sure we get
8715 * the local version for what we do here.
8720 #if !defined(PERL_IMPLICIT_CONTEXT)
8721 # define readdir Perl_readdir
8723 # define readdir(a) Perl_readdir(aTHX_ a)
8726 /* Number of elements in vms_versions array */
8727 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
8730 * Open a directory, return a handle for later use.
8732 /*{{{ DIR *opendir(char*name) */
8734 Perl_opendir(pTHX_ const char *name)
8742 if (decc_efs_charset) {
8743 unix_flag = is_unix_filespec(name);
8746 Newx(dir, VMS_MAXRSS, char);
8747 if (do_tovmspath(name,dir,0,NULL) == NULL) {
8751 /* Check access before stat; otherwise stat does not
8752 * accurately report whether it's a directory.
8754 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8755 /* cando_by_name has already set errno */
8759 if (flex_stat(dir,&sb) == -1) return NULL;
8760 if (!S_ISDIR(sb.st_mode)) {
8762 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
8765 /* Get memory for the handle, and the pattern. */
8767 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8769 /* Fill in the fields; mainly playing with the descriptor. */
8770 sprintf(dd->pattern, "%s*.*",dir);
8776 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8777 dd->pat.dsc$a_pointer = dd->pattern;
8778 dd->pat.dsc$w_length = strlen(dd->pattern);
8779 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8780 dd->pat.dsc$b_class = DSC$K_CLASS_S;
8781 #if defined(USE_ITHREADS)
8782 Newx(dd->mutex,1,perl_mutex);
8783 MUTEX_INIT( (perl_mutex *) dd->mutex );
8789 } /* end of opendir() */
8793 * Set the flag to indicate we want versions or not.
8795 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8797 vmsreaddirversions(DIR *dd, int flag)
8800 dd->flags |= PERL_VMSDIR_M_VERSIONS;
8802 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8807 * Free up an opened directory.
8809 /*{{{ void closedir(DIR *dd)*/
8811 Perl_closedir(DIR *dd)
8815 sts = lib$find_file_end(&dd->context);
8816 Safefree(dd->pattern);
8817 #if defined(USE_ITHREADS)
8818 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8819 Safefree(dd->mutex);
8826 * Collect all the version numbers for the current file.
8829 collectversions(pTHX_ DIR *dd)
8831 struct dsc$descriptor_s pat;
8832 struct dsc$descriptor_s res;
8834 char *p, *text, *buff;
8836 unsigned long context, tmpsts;
8838 /* Convenient shorthand. */
8841 /* Add the version wildcard, ignoring the "*.*" put on before */
8842 i = strlen(dd->pattern);
8843 Newx(text,i + e->d_namlen + 3,char);
8844 strcpy(text, dd->pattern);
8845 sprintf(&text[i - 3], "%s;*", e->d_name);
8847 /* Set up the pattern descriptor. */
8848 pat.dsc$a_pointer = text;
8849 pat.dsc$w_length = i + e->d_namlen - 1;
8850 pat.dsc$b_dtype = DSC$K_DTYPE_T;
8851 pat.dsc$b_class = DSC$K_CLASS_S;
8853 /* Set up result descriptor. */
8854 Newx(buff, VMS_MAXRSS, char);
8855 res.dsc$a_pointer = buff;
8856 res.dsc$w_length = VMS_MAXRSS - 1;
8857 res.dsc$b_dtype = DSC$K_DTYPE_T;
8858 res.dsc$b_class = DSC$K_CLASS_S;
8860 /* Read files, collecting versions. */
8861 for (context = 0, e->vms_verscount = 0;
8862 e->vms_verscount < VERSIZE(e);
8863 e->vms_verscount++) {
8865 unsigned long flags = 0;
8867 #ifdef VMS_LONGNAME_SUPPORT
8868 flags = LIB$M_FIL_LONG_NAMES;
8870 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8871 if (tmpsts == RMS$_NMF || context == 0) break;
8873 buff[VMS_MAXRSS - 1] = '\0';
8874 if ((p = strchr(buff, ';')))
8875 e->vms_versions[e->vms_verscount] = atoi(p + 1);
8877 e->vms_versions[e->vms_verscount] = -1;
8880 _ckvmssts(lib$find_file_end(&context));
8884 } /* end of collectversions() */
8887 * Read the next entry from the directory.
8889 /*{{{ struct dirent *readdir(DIR *dd)*/
8891 Perl_readdir(pTHX_ DIR *dd)
8893 struct dsc$descriptor_s res;
8895 unsigned long int tmpsts;
8897 unsigned long flags = 0;
8898 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8899 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8901 /* Set up result descriptor, and get next file. */
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 #ifdef VMS_LONGNAME_SUPPORT
8909 flags = LIB$M_FIL_LONG_NAMES;
8912 tmpsts = lib$find_file
8913 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8914 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
8915 if (!(tmpsts & 1)) {
8916 set_vaxc_errno(tmpsts);
8919 set_errno(EACCES); break;
8921 set_errno(ENODEV); break;
8923 set_errno(ENOTDIR); break;
8924 case RMS$_FNF: case RMS$_DNF:
8925 set_errno(ENOENT); break;
8933 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8934 if (!decc_efs_case_preserve) {
8935 buff[VMS_MAXRSS - 1] = '\0';
8936 for (p = buff; *p; p++) *p = _tolower(*p);
8939 /* we don't want to force to lowercase, just null terminate */
8940 buff[res.dsc$w_length] = '\0';
8942 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
8945 /* Skip any directory component and just copy the name. */
8946 sts = vms_split_path
8961 /* Drop NULL extensions on UNIX file specification */
8962 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8963 (e_len == 1) && decc_readdir_dropdotnotype)) {
8968 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8969 dd->entry.d_name[n_len + e_len] = '\0';
8970 dd->entry.d_namlen = strlen(dd->entry.d_name);
8972 /* Convert the filename to UNIX format if needed */
8973 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8975 /* Translate the encoded characters. */
8976 /* Fixme: unicode handling could result in embedded 0 characters */
8977 if (strchr(dd->entry.d_name, '^') != NULL) {
8981 p = dd->entry.d_name;
8985 x = copy_expand_vms_filename_escape(q, p, &y);
8989 /* if y > 1, then this is a wide file specification */
8990 /* Wide file specifications need to be passed in Perl */
8991 /* counted strings apparently with a unicode flag */
8994 strcpy(dd->entry.d_name, new_name);
8998 dd->entry.vms_verscount = 0;
8999 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9003 } /* end of readdir() */
9007 * Read the next entry from the directory -- thread-safe version.
9009 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9011 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9015 MUTEX_LOCK( (perl_mutex *) dd->mutex );
9017 entry = readdir(dd);
9019 retval = ( *result == NULL ? errno : 0 );
9021 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9025 } /* end of readdir_r() */
9029 * Return something that can be used in a seekdir later.
9031 /*{{{ long telldir(DIR *dd)*/
9033 Perl_telldir(DIR *dd)
9040 * Return to a spot where we used to be. Brute force.
9042 /*{{{ void seekdir(DIR *dd,long count)*/
9044 Perl_seekdir(pTHX_ DIR *dd, long count)
9048 /* If we haven't done anything yet... */
9052 /* Remember some state, and clear it. */
9053 old_flags = dd->flags;
9054 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9055 _ckvmssts(lib$find_file_end(&dd->context));
9058 /* The increment is in readdir(). */
9059 for (dd->count = 0; dd->count < count; )
9062 dd->flags = old_flags;
9064 } /* end of seekdir() */
9067 /* VMS subprocess management
9069 * my_vfork() - just a vfork(), after setting a flag to record that
9070 * the current script is trying a Unix-style fork/exec.
9072 * vms_do_aexec() and vms_do_exec() are called in response to the
9073 * perl 'exec' function. If this follows a vfork call, then they
9074 * call out the regular perl routines in doio.c which do an
9075 * execvp (for those who really want to try this under VMS).
9076 * Otherwise, they do exactly what the perl docs say exec should
9077 * do - terminate the current script and invoke a new command
9078 * (See below for notes on command syntax.)
9080 * do_aspawn() and do_spawn() implement the VMS side of the perl
9081 * 'system' function.
9083 * Note on command arguments to perl 'exec' and 'system': When handled
9084 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9085 * are concatenated to form a DCL command string. If the first arg
9086 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9087 * the command string is handed off to DCL directly. Otherwise,
9088 * the first token of the command is taken as the filespec of an image
9089 * to run. The filespec is expanded using a default type of '.EXE' and
9090 * the process defaults for device, directory, etc., and if found, the resultant
9091 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9092 * the command string as parameters. This is perhaps a bit complicated,
9093 * but I hope it will form a happy medium between what VMS folks expect
9094 * from lib$spawn and what Unix folks expect from exec.
9097 static int vfork_called;
9099 /*{{{int my_vfork()*/
9110 vms_execfree(struct dsc$descriptor_s *vmscmd)
9113 if (vmscmd->dsc$a_pointer) {
9114 PerlMem_free(vmscmd->dsc$a_pointer);
9116 PerlMem_free(vmscmd);
9121 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9123 char *junk, *tmps = Nullch;
9124 register size_t cmdlen = 0;
9131 tmps = SvPV(really,rlen);
9138 for (idx++; idx <= sp; idx++) {
9140 junk = SvPVx(*idx,rlen);
9141 cmdlen += rlen ? rlen + 1 : 0;
9144 Newx(PL_Cmd, cmdlen+1, char);
9146 if (tmps && *tmps) {
9147 strcpy(PL_Cmd,tmps);
9150 else *PL_Cmd = '\0';
9151 while (++mark <= sp) {
9153 char *s = SvPVx(*mark,n_a);
9155 if (*PL_Cmd) strcat(PL_Cmd," ");
9161 } /* end of setup_argstr() */
9164 static unsigned long int
9165 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9166 struct dsc$descriptor_s **pvmscmd)
9168 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9169 char image_name[NAM$C_MAXRSS+1];
9170 char image_argv[NAM$C_MAXRSS+1];
9171 $DESCRIPTOR(defdsc,".EXE");
9172 $DESCRIPTOR(defdsc2,".");
9173 $DESCRIPTOR(resdsc,resspec);
9174 struct dsc$descriptor_s *vmscmd;
9175 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9176 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9177 register char *s, *rest, *cp, *wordbreak;
9182 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9183 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9185 /* Make a copy for modification */
9186 cmdlen = strlen(incmd);
9187 cmd = PerlMem_malloc(cmdlen+1);
9188 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9189 strncpy(cmd, incmd, cmdlen);
9194 vmscmd->dsc$a_pointer = NULL;
9195 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
9196 vmscmd->dsc$b_class = DSC$K_CLASS_S;
9197 vmscmd->dsc$w_length = 0;
9198 if (pvmscmd) *pvmscmd = vmscmd;
9200 if (suggest_quote) *suggest_quote = 0;
9202 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9204 return CLI$_BUFOVF; /* continuation lines currently unsupported */
9209 while (*s && isspace(*s)) s++;
9211 if (*s == '@' || *s == '$') {
9212 vmsspec[0] = *s; rest = s + 1;
9213 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9215 else { cp = vmsspec; rest = s; }
9216 if (*rest == '.' || *rest == '/') {
9219 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9220 rest++, cp2++) *cp2 = *rest;
9222 if (do_tovmsspec(resspec,cp,0,NULL)) {
9225 for (cp2 = vmsspec + strlen(vmsspec);
9226 *rest && cp2 - vmsspec < sizeof vmsspec;
9227 rest++, cp2++) *cp2 = *rest;
9232 /* Intuit whether verb (first word of cmd) is a DCL command:
9233 * - if first nonspace char is '@', it's a DCL indirection
9235 * - if verb contains a filespec separator, it's not a DCL command
9236 * - if it doesn't, caller tells us whether to default to a DCL
9237 * command, or to a local image unless told it's DCL (by leading '$')
9241 if (suggest_quote) *suggest_quote = 1;
9243 register char *filespec = strpbrk(s,":<[.;");
9244 rest = wordbreak = strpbrk(s," \"\t/");
9245 if (!wordbreak) wordbreak = s + strlen(s);
9246 if (*s == '$') check_img = 0;
9247 if (filespec && (filespec < wordbreak)) isdcl = 0;
9248 else isdcl = !check_img;
9253 imgdsc.dsc$a_pointer = s;
9254 imgdsc.dsc$w_length = wordbreak - s;
9255 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9257 _ckvmssts(lib$find_file_end(&cxt));
9258 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9259 if (!(retsts & 1) && *s == '$') {
9260 _ckvmssts(lib$find_file_end(&cxt));
9261 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9262 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9264 _ckvmssts(lib$find_file_end(&cxt));
9265 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9269 _ckvmssts(lib$find_file_end(&cxt));
9274 while (*s && !isspace(*s)) s++;
9277 /* check that it's really not DCL with no file extension */
9278 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9280 char b[256] = {0,0,0,0};
9281 read(fileno(fp), b, 256);
9282 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9286 /* Check for script */
9288 if ((b[0] == '#') && (b[1] == '!'))
9290 #ifdef ALTERNATE_SHEBANG
9292 shebang_len = strlen(ALTERNATE_SHEBANG);
9293 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9295 perlstr = strstr("perl",b);
9296 if (perlstr == NULL)
9304 if (shebang_len > 0) {
9307 char tmpspec[NAM$C_MAXRSS + 1];
9310 /* Image is following after white space */
9311 /*--------------------------------------*/
9312 while (isprint(b[i]) && isspace(b[i]))
9316 while (isprint(b[i]) && !isspace(b[i])) {
9317 tmpspec[j++] = b[i++];
9318 if (j >= NAM$C_MAXRSS)
9323 /* There may be some default parameters to the image */
9324 /*---------------------------------------------------*/
9326 while (isprint(b[i])) {
9327 image_argv[j++] = b[i++];
9328 if (j >= NAM$C_MAXRSS)
9331 while ((j > 0) && !isprint(image_argv[j-1]))
9335 /* It will need to be converted to VMS format and validated */
9336 if (tmpspec[0] != '\0') {
9339 /* Try to find the exact program requested to be run */
9340 /*---------------------------------------------------*/
9341 iname = do_rmsexpand
9342 (tmpspec, image_name, 0, ".exe",
9343 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9344 if (iname != NULL) {
9345 if (cando_by_name_int
9346 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9347 /* MCR prefix needed */
9351 /* Try again with a null type */
9352 /*----------------------------*/
9353 iname = do_rmsexpand
9354 (tmpspec, image_name, 0, ".",
9355 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9356 if (iname != NULL) {
9357 if (cando_by_name_int
9358 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9359 /* MCR prefix needed */
9365 /* Did we find the image to run the script? */
9366 /*------------------------------------------*/
9370 /* Assume DCL or foreign command exists */
9371 /*--------------------------------------*/
9372 tchr = strrchr(tmpspec, '/');
9379 strcpy(image_name, tchr);
9387 if (check_img && isdcl) return RMS$_FNF;
9389 if (cando_by_name(S_IXUSR,0,resspec)) {
9390 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9391 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9393 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9394 if (image_name[0] != 0) {
9395 strcat(vmscmd->dsc$a_pointer, image_name);
9396 strcat(vmscmd->dsc$a_pointer, " ");
9398 } else if (image_name[0] != 0) {
9399 strcpy(vmscmd->dsc$a_pointer, image_name);
9400 strcat(vmscmd->dsc$a_pointer, " ");
9402 strcpy(vmscmd->dsc$a_pointer,"@");
9404 if (suggest_quote) *suggest_quote = 1;
9406 /* If there is an image name, use original command */
9407 if (image_name[0] == 0)
9408 strcat(vmscmd->dsc$a_pointer,resspec);
9411 while (*rest && isspace(*rest)) rest++;
9414 if (image_argv[0] != 0) {
9415 strcat(vmscmd->dsc$a_pointer,image_argv);
9416 strcat(vmscmd->dsc$a_pointer, " ");
9422 rest_len = strlen(rest);
9423 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9424 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9425 strcat(vmscmd->dsc$a_pointer,rest);
9427 retsts = CLI$_BUFOVF;
9429 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9431 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9437 /* It's either a DCL command or we couldn't find a suitable image */
9438 vmscmd->dsc$w_length = strlen(cmd);
9440 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9441 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9442 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9446 /* check if it's a symbol (for quoting purposes) */
9447 if (suggest_quote && !*suggest_quote) {
9449 char equiv[LNM$C_NAMLENGTH];
9450 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9451 eqvdsc.dsc$a_pointer = equiv;
9453 iss = lib$get_symbol(vmscmd,&eqvdsc);
9454 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9456 if (!(retsts & 1)) {
9457 /* just hand off status values likely to be due to user error */
9458 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9459 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9460 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9461 else { _ckvmssts(retsts); }
9464 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9466 } /* end of setup_cmddsc() */
9469 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9471 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9477 if (vfork_called) { /* this follows a vfork - act Unixish */
9479 if (vfork_called < 0) {
9480 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9483 else return do_aexec(really,mark,sp);
9485 /* no vfork - act VMSish */
9486 cmd = setup_argstr(aTHX_ really,mark,sp);
9487 exec_sts = vms_do_exec(cmd);
9488 Safefree(cmd); /* Clean up from setup_argstr() */
9493 } /* end of vms_do_aexec() */
9496 /* {{{bool vms_do_exec(char *cmd) */
9498 Perl_vms_do_exec(pTHX_ const char *cmd)
9500 struct dsc$descriptor_s *vmscmd;
9502 if (vfork_called) { /* this follows a vfork - act Unixish */
9504 if (vfork_called < 0) {
9505 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9508 else return do_exec(cmd);
9511 { /* no vfork - act VMSish */
9512 unsigned long int retsts;
9515 TAINT_PROPER("exec");
9516 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9517 retsts = lib$do_command(vmscmd);
9520 case RMS$_FNF: case RMS$_DNF:
9521 set_errno(ENOENT); break;
9523 set_errno(ENOTDIR); break;
9525 set_errno(ENODEV); break;
9527 set_errno(EACCES); break;
9529 set_errno(EINVAL); break;
9530 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9531 set_errno(E2BIG); break;
9532 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9533 _ckvmssts(retsts); /* fall through */
9534 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9537 set_vaxc_errno(retsts);
9538 if (ckWARN(WARN_EXEC)) {
9539 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9540 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9542 vms_execfree(vmscmd);
9547 } /* end of vms_do_exec() */
9550 unsigned long int Perl_do_spawn(pTHX_ const char *);
9552 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9554 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9556 unsigned long int sts;
9560 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9561 sts = do_spawn(cmd);
9562 /* pp_sys will clean up cmd */
9566 } /* end of do_aspawn() */
9569 /* {{{unsigned long int do_spawn(char *cmd) */
9571 Perl_do_spawn(pTHX_ const char *cmd)
9573 unsigned long int sts, substs;
9575 /* The caller of this routine expects to Safefree(PL_Cmd) */
9576 Newx(PL_Cmd,10,char);
9579 TAINT_PROPER("spawn");
9580 if (!cmd || !*cmd) {
9581 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9584 case RMS$_FNF: case RMS$_DNF:
9585 set_errno(ENOENT); break;
9587 set_errno(ENOTDIR); break;
9589 set_errno(ENODEV); break;
9591 set_errno(EACCES); break;
9593 set_errno(EINVAL); break;
9594 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9595 set_errno(E2BIG); break;
9596 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9597 _ckvmssts(sts); /* fall through */
9598 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9601 set_vaxc_errno(sts);
9602 if (ckWARN(WARN_EXEC)) {
9603 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9611 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9616 } /* end of do_spawn() */
9620 static unsigned int *sockflags, sockflagsize;
9623 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9624 * routines found in some versions of the CRTL can't deal with sockets.
9625 * We don't shim the other file open routines since a socket isn't
9626 * likely to be opened by a name.
9628 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9629 FILE *my_fdopen(int fd, const char *mode)
9631 FILE *fp = fdopen(fd, mode);
9634 unsigned int fdoff = fd / sizeof(unsigned int);
9635 Stat_t sbuf; /* native stat; we don't need flex_stat */
9636 if (!sockflagsize || fdoff > sockflagsize) {
9637 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
9638 else Newx (sockflags,fdoff+2,unsigned int);
9639 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9640 sockflagsize = fdoff + 2;
9642 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9643 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9652 * Clear the corresponding bit when the (possibly) socket stream is closed.
9653 * There still a small hole: we miss an implicit close which might occur
9654 * via freopen(). >> Todo
9656 /*{{{ int my_fclose(FILE *fp)*/
9657 int my_fclose(FILE *fp) {
9659 unsigned int fd = fileno(fp);
9660 unsigned int fdoff = fd / sizeof(unsigned int);
9662 if (sockflagsize && fdoff <= sockflagsize)
9663 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9671 * A simple fwrite replacement which outputs itmsz*nitm chars without
9672 * introducing record boundaries every itmsz chars.
9673 * We are using fputs, which depends on a terminating null. We may
9674 * well be writing binary data, so we need to accommodate not only
9675 * data with nulls sprinkled in the middle but also data with no null
9678 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9680 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9682 register char *cp, *end, *cpd, *data;
9683 register unsigned int fd = fileno(dest);
9684 register unsigned int fdoff = fd / sizeof(unsigned int);
9686 int bufsize = itmsz * nitm + 1;
9688 if (fdoff < sockflagsize &&
9689 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9690 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9694 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9695 memcpy( data, src, itmsz*nitm );
9696 data[itmsz*nitm] = '\0';
9698 end = data + itmsz * nitm;
9699 retval = (int) nitm; /* on success return # items written */
9702 while (cpd <= end) {
9703 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9704 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9706 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9710 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9713 } /* end of my_fwrite() */
9716 /*{{{ int my_flush(FILE *fp)*/
9718 Perl_my_flush(pTHX_ FILE *fp)
9721 if ((res = fflush(fp)) == 0 && fp) {
9722 #ifdef VMS_DO_SOCKETS
9724 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9726 res = fsync(fileno(fp));
9729 * If the flush succeeded but set end-of-file, we need to clear
9730 * the error because our caller may check ferror(). BTW, this
9731 * probably means we just flushed an empty file.
9733 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9740 * Here are replacements for the following Unix routines in the VMS environment:
9741 * getpwuid Get information for a particular UIC or UID
9742 * getpwnam Get information for a named user
9743 * getpwent Get information for each user in the rights database
9744 * setpwent Reset search to the start of the rights database
9745 * endpwent Finish searching for users in the rights database
9747 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9748 * (defined in pwd.h), which contains the following fields:-
9750 * char *pw_name; Username (in lower case)
9751 * char *pw_passwd; Hashed password
9752 * unsigned int pw_uid; UIC
9753 * unsigned int pw_gid; UIC group number
9754 * char *pw_unixdir; Default device/directory (VMS-style)
9755 * char *pw_gecos; Owner name
9756 * char *pw_dir; Default device/directory (Unix-style)
9757 * char *pw_shell; Default CLI name (eg. DCL)
9759 * If the specified user does not exist, getpwuid and getpwnam return NULL.
9761 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9762 * not the UIC member number (eg. what's returned by getuid()),
9763 * getpwuid() can accept either as input (if uid is specified, the caller's
9764 * UIC group is used), though it won't recognise gid=0.
9766 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9767 * information about other users in your group or in other groups, respectively.
9768 * If the required privilege is not available, then these routines fill only
9769 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9772 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9775 /* sizes of various UAF record fields */
9776 #define UAI$S_USERNAME 12
9777 #define UAI$S_IDENT 31
9778 #define UAI$S_OWNER 31
9779 #define UAI$S_DEFDEV 31
9780 #define UAI$S_DEFDIR 63
9781 #define UAI$S_DEFCLI 31
9784 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
9785 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9786 (uic).uic$v_group != UIC$K_WILD_GROUP)
9788 static char __empty[]= "";
9789 static struct passwd __passwd_empty=
9790 {(char *) __empty, (char *) __empty, 0, 0,
9791 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9792 static int contxt= 0;
9793 static struct passwd __pwdcache;
9794 static char __pw_namecache[UAI$S_IDENT+1];
9797 * This routine does most of the work extracting the user information.
9799 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9802 unsigned char length;
9803 char pw_gecos[UAI$S_OWNER+1];
9805 static union uicdef uic;
9807 unsigned char length;
9808 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9811 unsigned char length;
9812 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9815 unsigned char length;
9816 char pw_shell[UAI$S_DEFCLI+1];
9818 static char pw_passwd[UAI$S_PWD+1];
9820 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9821 struct dsc$descriptor_s name_desc;
9822 unsigned long int sts;
9824 static struct itmlst_3 itmlst[]= {
9825 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
9826 {sizeof(uic), UAI$_UIC, &uic, &luic},
9827 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
9828 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
9829 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
9830 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
9831 {0, 0, NULL, NULL}};
9833 name_desc.dsc$w_length= strlen(name);
9834 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9835 name_desc.dsc$b_class= DSC$K_CLASS_S;
9836 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9838 /* Note that sys$getuai returns many fields as counted strings. */
9839 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9840 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9841 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9843 else { _ckvmssts(sts); }
9844 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
9846 if ((int) owner.length < lowner) lowner= (int) owner.length;
9847 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9848 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9849 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9850 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9851 owner.pw_gecos[lowner]= '\0';
9852 defdev.pw_dir[ldefdev+ldefdir]= '\0';
9853 defcli.pw_shell[ldefcli]= '\0';
9854 if (valid_uic(uic)) {
9855 pwd->pw_uid= uic.uic$l_uic;
9856 pwd->pw_gid= uic.uic$v_group;
9859 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9860 pwd->pw_passwd= pw_passwd;
9861 pwd->pw_gecos= owner.pw_gecos;
9862 pwd->pw_dir= defdev.pw_dir;
9863 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9864 pwd->pw_shell= defcli.pw_shell;
9865 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9867 ldir= strlen(pwd->pw_unixdir) - 1;
9868 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9871 strcpy(pwd->pw_unixdir, pwd->pw_dir);
9872 if (!decc_efs_case_preserve)
9873 __mystrtolower(pwd->pw_unixdir);
9878 * Get information for a named user.
9880 /*{{{struct passwd *getpwnam(char *name)*/
9881 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9883 struct dsc$descriptor_s name_desc;
9885 unsigned long int status, sts;
9887 __pwdcache = __passwd_empty;
9888 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9889 /* We still may be able to determine pw_uid and pw_gid */
9890 name_desc.dsc$w_length= strlen(name);
9891 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9892 name_desc.dsc$b_class= DSC$K_CLASS_S;
9893 name_desc.dsc$a_pointer= (char *) name;
9894 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9895 __pwdcache.pw_uid= uic.uic$l_uic;
9896 __pwdcache.pw_gid= uic.uic$v_group;
9899 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9900 set_vaxc_errno(sts);
9901 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9904 else { _ckvmssts(sts); }
9907 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9908 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9909 __pwdcache.pw_name= __pw_namecache;
9911 } /* end of my_getpwnam() */
9915 * Get information for a particular UIC or UID.
9916 * Called by my_getpwent with uid=-1 to list all users.
9918 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9919 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9921 const $DESCRIPTOR(name_desc,__pw_namecache);
9922 unsigned short lname;
9924 unsigned long int status;
9926 if (uid == (unsigned int) -1) {
9928 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9929 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9930 set_vaxc_errno(status);
9931 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9935 else { _ckvmssts(status); }
9936 } while (!valid_uic (uic));
9940 if (!uic.uic$v_group)
9941 uic.uic$v_group= PerlProc_getgid();
9943 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9944 else status = SS$_IVIDENT;
9945 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9946 status == RMS$_PRV) {
9947 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9950 else { _ckvmssts(status); }
9952 __pw_namecache[lname]= '\0';
9953 __mystrtolower(__pw_namecache);
9955 __pwdcache = __passwd_empty;
9956 __pwdcache.pw_name = __pw_namecache;
9958 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9959 The identifier's value is usually the UIC, but it doesn't have to be,
9960 so if we can, we let fillpasswd update this. */
9961 __pwdcache.pw_uid = uic.uic$l_uic;
9962 __pwdcache.pw_gid = uic.uic$v_group;
9964 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9967 } /* end of my_getpwuid() */
9971 * Get information for next user.
9973 /*{{{struct passwd *my_getpwent()*/
9974 struct passwd *Perl_my_getpwent(pTHX)
9976 return (my_getpwuid((unsigned int) -1));
9981 * Finish searching rights database for users.
9983 /*{{{void my_endpwent()*/
9984 void Perl_my_endpwent(pTHX)
9987 _ckvmssts(sys$finish_rdb(&contxt));
9993 #ifdef HOMEGROWN_POSIX_SIGNALS
9994 /* Signal handling routines, pulled into the core from POSIX.xs.
9996 * We need these for threads, so they've been rolled into the core,
9997 * rather than left in POSIX.xs.
9999 * (DRS, Oct 23, 1997)
10002 /* sigset_t is atomic under VMS, so these routines are easy */
10003 /*{{{int my_sigemptyset(sigset_t *) */
10004 int my_sigemptyset(sigset_t *set) {
10005 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10006 *set = 0; return 0;
10011 /*{{{int my_sigfillset(sigset_t *)*/
10012 int my_sigfillset(sigset_t *set) {
10014 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10015 for (i = 0; i < NSIG; i++) *set |= (1 << i);
10021 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10022 int my_sigaddset(sigset_t *set, int sig) {
10023 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10024 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10025 *set |= (1 << (sig - 1));
10031 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10032 int my_sigdelset(sigset_t *set, int sig) {
10033 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10034 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10035 *set &= ~(1 << (sig - 1));
10041 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10042 int my_sigismember(sigset_t *set, int sig) {
10043 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10044 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10045 return *set & (1 << (sig - 1));
10050 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10051 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10054 /* If set and oset are both null, then things are badly wrong. Bail out. */
10055 if ((oset == NULL) && (set == NULL)) {
10056 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10060 /* If set's null, then we're just handling a fetch. */
10062 tempmask = sigblock(0);
10067 tempmask = sigsetmask(*set);
10070 tempmask = sigblock(*set);
10073 tempmask = sigblock(0);
10074 sigsetmask(*oset & ~tempmask);
10077 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10082 /* Did they pass us an oset? If so, stick our holding mask into it */
10089 #endif /* HOMEGROWN_POSIX_SIGNALS */
10092 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10093 * my_utime(), and flex_stat(), all of which operate on UTC unless
10094 * VMSISH_TIMES is true.
10096 /* method used to handle UTC conversions:
10097 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
10099 static int gmtime_emulation_type;
10100 /* number of secs to add to UTC POSIX-style time to get local time */
10101 static long int utc_offset_secs;
10103 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10104 * in vmsish.h. #undef them here so we can call the CRTL routines
10113 * DEC C previous to 6.0 corrupts the behavior of the /prefix
10114 * qualifier with the extern prefix pragma. This provisional
10115 * hack circumvents this prefix pragma problem in previous
10118 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10119 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10120 # pragma __extern_prefix save
10121 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
10122 # define gmtime decc$__utctz_gmtime
10123 # define localtime decc$__utctz_localtime
10124 # define time decc$__utc_time
10125 # pragma __extern_prefix restore
10127 struct tm *gmtime(), *localtime();
10133 static time_t toutc_dst(time_t loc) {
10136 if ((rsltmp = localtime(&loc)) == NULL) return -1;
10137 loc -= utc_offset_secs;
10138 if (rsltmp->tm_isdst) loc -= 3600;
10141 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10142 ((gmtime_emulation_type || my_time(NULL)), \
10143 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10144 ((secs) - utc_offset_secs))))
10146 static time_t toloc_dst(time_t utc) {
10149 utc += utc_offset_secs;
10150 if ((rsltmp = localtime(&utc)) == NULL) return -1;
10151 if (rsltmp->tm_isdst) utc += 3600;
10154 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10155 ((gmtime_emulation_type || my_time(NULL)), \
10156 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10157 ((secs) + utc_offset_secs))))
10159 #ifndef RTL_USES_UTC
10162 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
10163 DST starts on 1st sun of april at 02:00 std time
10164 ends on last sun of october at 02:00 dst time
10165 see the UCX management command reference, SET CONFIG TIMEZONE
10166 for formatting info.
10168 No, it's not as general as it should be, but then again, NOTHING
10169 will handle UK times in a sensible way.
10174 parse the DST start/end info:
10175 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10179 tz_parse_startend(char *s, struct tm *w, int *past)
10181 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10182 int ly, dozjd, d, m, n, hour, min, sec, j, k;
10187 if (!past) return 0;
10190 if (w->tm_year % 4 == 0) ly = 1;
10191 if (w->tm_year % 100 == 0) ly = 0;
10192 if (w->tm_year+1900 % 400 == 0) ly = 1;
10195 dozjd = isdigit(*s);
10196 if (*s == 'J' || *s == 'j' || dozjd) {
10197 if (!dozjd && !isdigit(*++s)) return 0;
10200 d = d*10 + *s++ - '0';
10202 d = d*10 + *s++ - '0';
10205 if (d == 0) return 0;
10206 if (d > 366) return 0;
10208 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
10211 } else if (*s == 'M' || *s == 'm') {
10212 if (!isdigit(*++s)) return 0;
10214 if (isdigit(*s)) m = 10*m + *s++ - '0';
10215 if (*s != '.') return 0;
10216 if (!isdigit(*++s)) return 0;
10218 if (n < 1 || n > 5) return 0;
10219 if (*s != '.') return 0;
10220 if (!isdigit(*++s)) return 0;
10222 if (d > 6) return 0;
10226 if (!isdigit(*++s)) return 0;
10228 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10230 if (!isdigit(*++s)) return 0;
10232 if (isdigit(*s)) min = 10*min + *s++ - '0';
10234 if (!isdigit(*++s)) return 0;
10236 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10246 if (w->tm_yday < d) goto before;
10247 if (w->tm_yday > d) goto after;
10249 if (w->tm_mon+1 < m) goto before;
10250 if (w->tm_mon+1 > m) goto after;
10252 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
10253 k = d - j; /* mday of first d */
10254 if (k <= 0) k += 7;
10255 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
10256 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10257 if (w->tm_mday < k) goto before;
10258 if (w->tm_mday > k) goto after;
10261 if (w->tm_hour < hour) goto before;
10262 if (w->tm_hour > hour) goto after;
10263 if (w->tm_min < min) goto before;
10264 if (w->tm_min > min) goto after;
10265 if (w->tm_sec < sec) goto before;
10279 /* parse the offset: (+|-)hh[:mm[:ss]] */
10282 tz_parse_offset(char *s, int *offset)
10284 int hour = 0, min = 0, sec = 0;
10287 if (!offset) return 0;
10289 if (*s == '-') {neg++; s++;}
10290 if (*s == '+') s++;
10291 if (!isdigit(*s)) return 0;
10293 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10294 if (hour > 24) return 0;
10296 if (!isdigit(*++s)) return 0;
10298 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10299 if (min > 59) return 0;
10301 if (!isdigit(*++s)) return 0;
10303 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10304 if (sec > 59) return 0;
10308 *offset = (hour*60+min)*60 + sec;
10309 if (neg) *offset = -*offset;
10314 input time is w, whatever type of time the CRTL localtime() uses.
10315 sets dst, the zone, and the gmtoff (seconds)
10317 caches the value of TZ and UCX$TZ env variables; note that
10318 my_setenv looks for these and sets a flag if they're changed
10321 We have to watch out for the "australian" case (dst starts in
10322 october, ends in april)...flagged by "reverse" and checked by
10323 scanning through the months of the previous year.
10328 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10333 char *dstzone, *tz, *s_start, *s_end;
10334 int std_off, dst_off, isdst;
10335 int y, dststart, dstend;
10336 static char envtz[1025]; /* longer than any logical, symbol, ... */
10337 static char ucxtz[1025];
10338 static char reversed = 0;
10344 reversed = -1; /* flag need to check */
10345 envtz[0] = ucxtz[0] = '\0';
10346 tz = my_getenv("TZ",0);
10347 if (tz) strcpy(envtz, tz);
10348 tz = my_getenv("UCX$TZ",0);
10349 if (tz) strcpy(ucxtz, tz);
10350 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
10353 if (!*tz) tz = ucxtz;
10356 while (isalpha(*s)) s++;
10357 s = tz_parse_offset(s, &std_off);
10359 if (!*s) { /* no DST, hurray we're done! */
10365 while (isalpha(*s)) s++;
10366 s2 = tz_parse_offset(s, &dst_off);
10370 dst_off = std_off - 3600;
10373 if (!*s) { /* default dst start/end?? */
10374 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
10375 s = strchr(ucxtz,',');
10377 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
10379 if (*s != ',') return 0;
10382 when = _toutc(when); /* convert to utc */
10383 when = when - std_off; /* convert to pseudolocal time*/
10385 w2 = localtime(&when);
10388 s = tz_parse_startend(s_start,w2,&dststart);
10390 if (*s != ',') return 0;
10393 when = _toutc(when); /* convert to utc */
10394 when = when - dst_off; /* convert to pseudolocal time*/
10395 w2 = localtime(&when);
10396 if (w2->tm_year != y) { /* spans a year, just check one time */
10397 when += dst_off - std_off;
10398 w2 = localtime(&when);
10401 s = tz_parse_startend(s_end,w2,&dstend);
10404 if (reversed == -1) { /* need to check if start later than end */
10408 if (when < 2*365*86400) {
10409 when += 2*365*86400;
10413 w2 =localtime(&when);
10414 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
10416 for (j = 0; j < 12; j++) {
10417 w2 =localtime(&when);
10418 tz_parse_startend(s_start,w2,&ds);
10419 tz_parse_startend(s_end,w2,&de);
10420 if (ds != de) break;
10424 if (de && !ds) reversed = 1;
10427 isdst = dststart && !dstend;
10428 if (reversed) isdst = dststart || !dstend;
10431 if (dst) *dst = isdst;
10432 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10433 if (isdst) tz = dstzone;
10435 while(isalpha(*tz)) *zone++ = *tz++;
10441 #endif /* !RTL_USES_UTC */
10443 /* my_time(), my_localtime(), my_gmtime()
10444 * By default traffic in UTC time values, using CRTL gmtime() or
10445 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10446 * Note: We need to use these functions even when the CRTL has working
10447 * UTC support, since they also handle C<use vmsish qw(times);>
10449 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
10450 * Modified by Charles Bailey <bailey@newman.upenn.edu>
10453 /*{{{time_t my_time(time_t *timep)*/
10454 time_t Perl_my_time(pTHX_ time_t *timep)
10459 if (gmtime_emulation_type == 0) {
10461 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
10462 /* results of calls to gmtime() and localtime() */
10463 /* for same &base */
10465 gmtime_emulation_type++;
10466 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10467 char off[LNM$C_NAMLENGTH+1];;
10469 gmtime_emulation_type++;
10470 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10471 gmtime_emulation_type++;
10472 utc_offset_secs = 0;
10473 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10475 else { utc_offset_secs = atol(off); }
10477 else { /* We've got a working gmtime() */
10478 struct tm gmt, local;
10481 tm_p = localtime(&base);
10483 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
10484 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10485 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
10486 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
10491 # ifdef VMSISH_TIME
10492 # ifdef RTL_USES_UTC
10493 if (VMSISH_TIME) when = _toloc(when);
10495 if (!VMSISH_TIME) when = _toutc(when);
10498 if (timep != NULL) *timep = when;
10501 } /* end of my_time() */
10505 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10507 Perl_my_gmtime(pTHX_ const time_t *timep)
10513 if (timep == NULL) {
10514 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10517 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10520 # ifdef VMSISH_TIME
10521 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10523 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
10524 return gmtime(&when);
10526 /* CRTL localtime() wants local time as input, so does no tz correction */
10527 rsltmp = localtime(&when);
10528 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
10531 } /* end of my_gmtime() */
10535 /*{{{struct tm *my_localtime(const time_t *timep)*/
10537 Perl_my_localtime(pTHX_ const time_t *timep)
10539 time_t when, whenutc;
10543 if (timep == NULL) {
10544 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10547 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10548 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10551 # ifdef RTL_USES_UTC
10552 # ifdef VMSISH_TIME
10553 if (VMSISH_TIME) when = _toutc(when);
10555 /* CRTL localtime() wants UTC as input, does tz correction itself */
10556 return localtime(&when);
10558 # else /* !RTL_USES_UTC */
10560 # ifdef VMSISH_TIME
10561 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
10562 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
10565 #ifndef RTL_USES_UTC
10566 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
10567 when = whenutc - offset; /* pseudolocal time*/
10570 /* CRTL localtime() wants local time as input, so does no tz correction */
10571 rsltmp = localtime(&when);
10572 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10576 } /* end of my_localtime() */
10579 /* Reset definitions for later calls */
10580 #define gmtime(t) my_gmtime(t)
10581 #define localtime(t) my_localtime(t)
10582 #define time(t) my_time(t)
10585 /* my_utime - update modification/access time of a file
10587 * VMS 7.3 and later implementation
10588 * Only the UTC translation is home-grown. The rest is handled by the
10589 * CRTL utime(), which will take into account the relevant feature
10590 * logicals and ODS-5 volume characteristics for true access times.
10592 * pre VMS 7.3 implementation:
10593 * The calling sequence is identical to POSIX utime(), but under
10594 * VMS with ODS-2, only the modification time is changed; ODS-2 does
10595 * not maintain access times. Restrictions differ from the POSIX
10596 * definition in that the time can be changed as long as the
10597 * caller has permission to execute the necessary IO$_MODIFY $QIO;
10598 * no separate checks are made to insure that the caller is the
10599 * owner of the file or has special privs enabled.
10600 * Code here is based on Joe Meadows' FILE utility.
10604 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10605 * to VMS epoch (01-JAN-1858 00:00:00.00)
10606 * in 100 ns intervals.
10608 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10610 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10611 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10613 #if __CRTL_VER >= 70300000
10614 struct utimbuf utc_utimes, *utc_utimesp;
10616 if (utimes != NULL) {
10617 utc_utimes.actime = utimes->actime;
10618 utc_utimes.modtime = utimes->modtime;
10619 # ifdef VMSISH_TIME
10620 /* If input was local; convert to UTC for sys svc */
10622 utc_utimes.actime = _toutc(utimes->actime);
10623 utc_utimes.modtime = _toutc(utimes->modtime);
10626 utc_utimesp = &utc_utimes;
10629 utc_utimesp = NULL;
10632 return utime(file, utc_utimesp);
10634 #else /* __CRTL_VER < 70300000 */
10638 long int bintime[2], len = 2, lowbit, unixtime,
10639 secscale = 10000000; /* seconds --> 100 ns intervals */
10640 unsigned long int chan, iosb[2], retsts;
10641 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10642 struct FAB myfab = cc$rms_fab;
10643 struct NAM mynam = cc$rms_nam;
10644 #if defined (__DECC) && defined (__VAX)
10645 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10646 * at least through VMS V6.1, which causes a type-conversion warning.
10648 # pragma message save
10649 # pragma message disable cvtdiftypes
10651 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10652 struct fibdef myfib;
10653 #if defined (__DECC) && defined (__VAX)
10654 /* This should be right after the declaration of myatr, but due
10655 * to a bug in VAX DEC C, this takes effect a statement early.
10657 # pragma message restore
10659 /* cast ok for read only parameter */
10660 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10661 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10662 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10664 if (file == NULL || *file == '\0') {
10665 SETERRNO(ENOENT, LIB$_INVARG);
10669 /* Convert to VMS format ensuring that it will fit in 255 characters */
10670 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10671 SETERRNO(ENOENT, LIB$_INVARG);
10674 if (utimes != NULL) {
10675 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
10676 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10677 * Since time_t is unsigned long int, and lib$emul takes a signed long int
10678 * as input, we force the sign bit to be clear by shifting unixtime right
10679 * one bit, then multiplying by an extra factor of 2 in lib$emul().
10681 lowbit = (utimes->modtime & 1) ? secscale : 0;
10682 unixtime = (long int) utimes->modtime;
10683 # ifdef VMSISH_TIME
10684 /* If input was UTC; convert to local for sys svc */
10685 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10687 unixtime >>= 1; secscale <<= 1;
10688 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10689 if (!(retsts & 1)) {
10690 SETERRNO(EVMSERR, retsts);
10693 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10694 if (!(retsts & 1)) {
10695 SETERRNO(EVMSERR, retsts);
10700 /* Just get the current time in VMS format directly */
10701 retsts = sys$gettim(bintime);
10702 if (!(retsts & 1)) {
10703 SETERRNO(EVMSERR, retsts);
10708 myfab.fab$l_fna = vmsspec;
10709 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10710 myfab.fab$l_nam = &mynam;
10711 mynam.nam$l_esa = esa;
10712 mynam.nam$b_ess = (unsigned char) sizeof esa;
10713 mynam.nam$l_rsa = rsa;
10714 mynam.nam$b_rss = (unsigned char) sizeof rsa;
10715 if (decc_efs_case_preserve)
10716 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10718 /* Look for the file to be affected, letting RMS parse the file
10719 * specification for us as well. I have set errno using only
10720 * values documented in the utime() man page for VMS POSIX.
10722 retsts = sys$parse(&myfab,0,0);
10723 if (!(retsts & 1)) {
10724 set_vaxc_errno(retsts);
10725 if (retsts == RMS$_PRV) set_errno(EACCES);
10726 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10727 else set_errno(EVMSERR);
10730 retsts = sys$search(&myfab,0,0);
10731 if (!(retsts & 1)) {
10732 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10733 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10734 set_vaxc_errno(retsts);
10735 if (retsts == RMS$_PRV) set_errno(EACCES);
10736 else if (retsts == RMS$_FNF) set_errno(ENOENT);
10737 else set_errno(EVMSERR);
10741 devdsc.dsc$w_length = mynam.nam$b_dev;
10742 /* cast ok for read only parameter */
10743 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10745 retsts = sys$assign(&devdsc,&chan,0,0);
10746 if (!(retsts & 1)) {
10747 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10748 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10749 set_vaxc_errno(retsts);
10750 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
10751 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
10752 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
10753 else set_errno(EVMSERR);
10757 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10758 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10760 memset((void *) &myfib, 0, sizeof myfib);
10761 #if defined(__DECC) || defined(__DECCXX)
10762 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10763 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10764 /* This prevents the revision time of the file being reset to the current
10765 * time as a result of our IO$_MODIFY $QIO. */
10766 myfib.fib$l_acctl = FIB$M_NORECORD;
10768 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10769 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10770 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10772 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10773 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10774 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10775 _ckvmssts(sys$dassgn(chan));
10776 if (retsts & 1) retsts = iosb[0];
10777 if (!(retsts & 1)) {
10778 set_vaxc_errno(retsts);
10779 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10780 else set_errno(EVMSERR);
10786 #endif /* #if __CRTL_VER >= 70300000 */
10788 } /* end of my_utime() */
10792 * flex_stat, flex_lstat, flex_fstat
10793 * basic stat, but gets it right when asked to stat
10794 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10797 #ifndef _USE_STD_STAT
10798 /* encode_dev packs a VMS device name string into an integer to allow
10799 * simple comparisons. This can be used, for example, to check whether two
10800 * files are located on the same device, by comparing their encoded device
10801 * names. Even a string comparison would not do, because stat() reuses the
10802 * device name buffer for each call; so without encode_dev, it would be
10803 * necessary to save the buffer and use strcmp (this would mean a number of
10804 * changes to the standard Perl code, to say nothing of what a Perl script
10805 * would have to do.
10807 * The device lock id, if it exists, should be unique (unless perhaps compared
10808 * with lock ids transferred from other nodes). We have a lock id if the disk is
10809 * mounted cluster-wide, which is when we tend to get long (host-qualified)
10810 * device names. Thus we use the lock id in preference, and only if that isn't
10811 * available, do we try to pack the device name into an integer (flagged by
10812 * the sign bit (LOCKID_MASK) being set).
10814 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10815 * name and its encoded form, but it seems very unlikely that we will find
10816 * two files on different disks that share the same encoded device names,
10817 * and even more remote that they will share the same file id (if the test
10818 * is to check for the same file).
10820 * A better method might be to use sys$device_scan on the first call, and to
10821 * search for the device, returning an index into the cached array.
10822 * The number returned would be more intelligible.
10823 * This is probably not worth it, and anyway would take quite a bit longer
10824 * on the first call.
10826 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
10827 static mydev_t encode_dev (pTHX_ const char *dev)
10830 unsigned long int f;
10835 if (!dev || !dev[0]) return 0;
10839 struct dsc$descriptor_s dev_desc;
10840 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10842 /* For cluster-mounted disks, the disk lock identifier is unique, so we
10843 can try that first. */
10844 dev_desc.dsc$w_length = strlen (dev);
10845 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
10846 dev_desc.dsc$b_class = DSC$K_CLASS_S;
10847 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
10848 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10849 if (!$VMS_STATUS_SUCCESS(status)) {
10851 case SS$_NOSUCHDEV:
10852 SETERRNO(ENODEV, status);
10858 if (lockid) return (lockid & ~LOCKID_MASK);
10862 /* Otherwise we try to encode the device name */
10866 for (q = dev + strlen(dev); q--; q >= dev) {
10871 else if (isalpha (toupper (*q)))
10872 c= toupper (*q) - 'A' + (char)10;
10874 continue; /* Skip '$'s */
10876 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
10878 enc += f * (unsigned long int) c;
10880 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
10882 } /* end of encode_dev() */
10883 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10884 device_no = encode_dev(aTHX_ devname)
10886 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10887 device_no = new_dev_no
10891 is_null_device(name)
10894 if (decc_bug_devnull != 0) {
10895 if (strncmp("/dev/null", name, 9) == 0)
10898 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10899 The underscore prefix, controller letter, and unit number are
10900 independently optional; for our purposes, the colon punctuation
10901 is not. The colon can be trailed by optional directory and/or
10902 filename, but two consecutive colons indicates a nodename rather
10903 than a device. [pr] */
10904 if (*name == '_') ++name;
10905 if (tolower(*name++) != 'n') return 0;
10906 if (tolower(*name++) != 'l') return 0;
10907 if (tolower(*name) == 'a') ++name;
10908 if (*name == '0') ++name;
10909 return (*name++ == ':') && (*name != ':');
10914 Perl_cando_by_name_int
10915 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10917 static char usrname[L_cuserid];
10918 static struct dsc$descriptor_s usrdsc =
10919 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10920 char vmsname[NAM$C_MAXRSS+1];
10922 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10923 unsigned short int retlen, trnlnm_iter_count;
10924 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10925 union prvdef curprv;
10926 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10927 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10928 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10929 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10930 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10932 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10934 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10936 if (!fname || !*fname) return FALSE;
10937 /* Make sure we expand logical names, since sys$check_access doesn't */
10940 if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10941 fileified = PerlMem_malloc(VMS_MAXRSS);
10942 if (!strpbrk(fname,"/]>:")) {
10943 strcpy(fileified,fname);
10944 trnlnm_iter_count = 0;
10945 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10946 trnlnm_iter_count++;
10947 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10951 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10952 PerlMem_free(fileified);
10955 retlen = namdsc.dsc$w_length = strlen(vmsname);
10956 namdsc.dsc$a_pointer = vmsname;
10957 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10958 vmsname[retlen-1] == ':') {
10959 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10960 namdsc.dsc$w_length = strlen(fileified);
10961 namdsc.dsc$a_pointer = fileified;
10965 retlen = namdsc.dsc$w_length = strlen(fname);
10966 namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10970 case S_IXUSR: case S_IXGRP: case S_IXOTH:
10971 access = ARM$M_EXECUTE;
10972 flags = CHP$M_READ;
10974 case S_IRUSR: case S_IRGRP: case S_IROTH:
10975 access = ARM$M_READ;
10976 flags = CHP$M_READ | CHP$M_USEREADALL;
10978 case S_IWUSR: case S_IWGRP: case S_IWOTH:
10979 access = ARM$M_WRITE;
10980 flags = CHP$M_READ | CHP$M_WRITE;
10982 case S_IDUSR: case S_IDGRP: case S_IDOTH:
10983 access = ARM$M_DELETE;
10984 flags = CHP$M_READ | CHP$M_WRITE;
10987 if (fileified != NULL)
10988 PerlMem_free(fileified);
10992 /* Before we call $check_access, create a user profile with the current
10993 * process privs since otherwise it just uses the default privs from the
10994 * UAF and might give false positives or negatives. This only works on
10995 * VMS versions v6.0 and later since that's when sys$create_user_profile
10996 * became available.
10999 /* get current process privs and username */
11000 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11001 _ckvmssts(iosb[0]);
11003 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11005 /* find out the space required for the profile */
11006 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11007 &usrprodsc.dsc$w_length,0));
11009 /* allocate space for the profile and get it filled in */
11010 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11011 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11012 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11013 &usrprodsc.dsc$w_length,0));
11015 /* use the profile to check access to the file; free profile & analyze results */
11016 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
11017 PerlMem_free(usrprodsc.dsc$a_pointer);
11018 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11022 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11026 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
11027 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11028 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11029 set_vaxc_errno(retsts);
11030 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11031 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11032 else set_errno(ENOENT);
11033 if (fileified != NULL)
11034 PerlMem_free(fileified);
11037 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11038 if (fileified != NULL)
11039 PerlMem_free(fileified);
11044 if (fileified != NULL)
11045 PerlMem_free(fileified);
11046 return FALSE; /* Should never get here */
11050 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
11051 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11052 * subset of the applicable information.
11055 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11057 return cando_by_name_int
11058 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11059 } /* end of cando() */
11063 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11065 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11067 return cando_by_name_int(bit, effective, fname, 0);
11069 } /* end of cando_by_name() */
11073 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11075 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11077 if (!fstat(fd,(stat_t *) statbufp)) {
11079 char *vms_filename;
11080 vms_filename = PerlMem_malloc(VMS_MAXRSS);
11081 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11083 /* Save name for cando by name in VMS format */
11084 cptr = getname(fd, vms_filename, 1);
11086 /* This should not happen, but just in case */
11087 if (cptr == NULL) {
11088 statbufp->st_devnam[0] = 0;
11091 /* Make sure that the saved name fits in 255 characters */
11092 cptr = do_rmsexpand
11094 statbufp->st_devnam,
11097 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11101 statbufp->st_devnam[0] = 0;
11103 PerlMem_free(vms_filename);
11105 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11107 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11109 # ifdef RTL_USES_UTC
11110 # ifdef VMSISH_TIME
11112 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11113 statbufp->st_atime = _toloc(statbufp->st_atime);
11114 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11118 # ifdef VMSISH_TIME
11119 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11123 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11124 statbufp->st_atime = _toutc(statbufp->st_atime);
11125 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11132 } /* end of flex_fstat() */
11135 #if !defined(__VAX) && __CRTL_VER >= 80200000
11143 #define lstat(_x, _y) stat(_x, _y)
11146 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11149 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11151 char fileified[VMS_MAXRSS];
11152 char temp_fspec[VMS_MAXRSS];
11155 int saved_errno, saved_vaxc_errno;
11157 if (!fspec) return retval;
11158 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11159 strcpy(temp_fspec, fspec);
11161 if (decc_bug_devnull != 0) {
11162 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11163 memset(statbufp,0,sizeof *statbufp);
11164 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11165 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11166 statbufp->st_uid = 0x00010001;
11167 statbufp->st_gid = 0x0001;
11168 time((time_t *)&statbufp->st_mtime);
11169 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11174 /* Try for a directory name first. If fspec contains a filename without
11175 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11176 * and sea:[wine.dark]water. exist, we prefer the directory here.
11177 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11178 * not sea:[wine.dark]., if the latter exists. If the intended target is
11179 * the file with null type, specify this by calling flex_stat() with
11180 * a '.' at the end of fspec.
11182 * If we are in Posix filespec mode, accept the filename as is.
11184 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11185 if (decc_posix_compliant_pathnames == 0) {
11187 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11188 if (lstat_flag == 0)
11189 retval = stat(fileified,(stat_t *) statbufp);
11191 retval = lstat(fileified,(stat_t *) statbufp);
11192 save_spec = fileified;
11195 if (lstat_flag == 0)
11196 retval = stat(temp_fspec,(stat_t *) statbufp);
11198 retval = lstat(temp_fspec,(stat_t *) statbufp);
11199 save_spec = temp_fspec;
11201 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11203 if (lstat_flag == 0)
11204 retval = stat(temp_fspec,(stat_t *) statbufp);
11206 retval = lstat(temp_fspec,(stat_t *) statbufp);
11207 save_spec = temp_fspec;
11212 cptr = do_rmsexpand
11213 (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11215 statbufp->st_devnam[0] = 0;
11217 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11219 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11220 # ifdef RTL_USES_UTC
11221 # ifdef VMSISH_TIME
11223 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11224 statbufp->st_atime = _toloc(statbufp->st_atime);
11225 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11229 # ifdef VMSISH_TIME
11230 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11234 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11235 statbufp->st_atime = _toutc(statbufp->st_atime);
11236 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11240 /* If we were successful, leave errno where we found it */
11241 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11244 } /* end of flex_stat_int() */
11247 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11249 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11251 return flex_stat_int(fspec, statbufp, 0);
11255 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11257 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11259 return flex_stat_int(fspec, statbufp, 1);
11264 /*{{{char *my_getlogin()*/
11265 /* VMS cuserid == Unix getlogin, except calling sequence */
11269 static char user[L_cuserid];
11270 return cuserid(user);
11275 /* rmscopy - copy a file using VMS RMS routines
11277 * Copies contents and attributes of spec_in to spec_out, except owner
11278 * and protection information. Name and type of spec_in are used as
11279 * defaults for spec_out. The third parameter specifies whether rmscopy()
11280 * should try to propagate timestamps from the input file to the output file.
11281 * If it is less than 0, no timestamps are preserved. If it is 0, then
11282 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
11283 * propagated to the output file at creation iff the output file specification
11284 * did not contain an explicit name or type, and the revision date is always
11285 * updated at the end of the copy operation. If it is greater than 0, then
11286 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11287 * other than the revision date should be propagated, and bit 1 indicates
11288 * that the revision date should be propagated.
11290 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11292 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11293 * Incorporates, with permission, some code from EZCOPY by Tim Adye
11294 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
11295 * as part of the Perl standard distribution under the terms of the
11296 * GNU General Public License or the Perl Artistic License. Copies
11297 * of each may be found in the Perl standard distribution.
11299 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11301 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11303 char *vmsin, * vmsout, *esa, *esa_out,
11305 unsigned long int i, sts, sts2;
11307 struct FAB fab_in, fab_out;
11308 struct RAB rab_in, rab_out;
11309 rms_setup_nam(nam);
11310 rms_setup_nam(nam_out);
11311 struct XABDAT xabdat;
11312 struct XABFHC xabfhc;
11313 struct XABRDT xabrdt;
11314 struct XABSUM xabsum;
11316 vmsin = PerlMem_malloc(VMS_MAXRSS);
11317 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11318 vmsout = PerlMem_malloc(VMS_MAXRSS);
11319 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11320 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11321 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11322 PerlMem_free(vmsin);
11323 PerlMem_free(vmsout);
11324 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11328 esa = PerlMem_malloc(VMS_MAXRSS);
11329 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11330 fab_in = cc$rms_fab;
11331 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11332 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11333 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11334 fab_in.fab$l_fop = FAB$M_SQO;
11335 rms_bind_fab_nam(fab_in, nam);
11336 fab_in.fab$l_xab = (void *) &xabdat;
11338 rsa = PerlMem_malloc(VMS_MAXRSS);
11339 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11340 rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11341 rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11342 rms_nam_esl(nam) = 0;
11343 rms_nam_rsl(nam) = 0;
11344 rms_nam_esll(nam) = 0;
11345 rms_nam_rsll(nam) = 0;
11346 #ifdef NAM$M_NO_SHORT_UPCASE
11347 if (decc_efs_case_preserve)
11348 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11351 xabdat = cc$rms_xabdat; /* To get creation date */
11352 xabdat.xab$l_nxt = (void *) &xabfhc;
11354 xabfhc = cc$rms_xabfhc; /* To get record length */
11355 xabfhc.xab$l_nxt = (void *) &xabsum;
11357 xabsum = cc$rms_xabsum; /* To get key and area information */
11359 if (!((sts = sys$open(&fab_in)) & 1)) {
11360 PerlMem_free(vmsin);
11361 PerlMem_free(vmsout);
11364 set_vaxc_errno(sts);
11366 case RMS$_FNF: case RMS$_DNF:
11367 set_errno(ENOENT); break;
11369 set_errno(ENOTDIR); break;
11371 set_errno(ENODEV); break;
11373 set_errno(EINVAL); break;
11375 set_errno(EACCES); break;
11377 set_errno(EVMSERR);
11384 fab_out.fab$w_ifi = 0;
11385 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11386 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11387 fab_out.fab$l_fop = FAB$M_SQO;
11388 rms_bind_fab_nam(fab_out, nam_out);
11389 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11390 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11391 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11392 esa_out = PerlMem_malloc(VMS_MAXRSS);
11393 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11394 rms_set_rsa(nam_out, NULL, 0);
11395 rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11397 if (preserve_dates == 0) { /* Act like DCL COPY */
11398 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11399 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
11400 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11401 PerlMem_free(vmsin);
11402 PerlMem_free(vmsout);
11405 PerlMem_free(esa_out);
11406 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11407 set_vaxc_errno(sts);
11410 fab_out.fab$l_xab = (void *) &xabdat;
11411 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11412 preserve_dates = 1;
11414 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
11415 preserve_dates =0; /* bitmask from this point forward */
11417 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11418 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11419 PerlMem_free(vmsin);
11420 PerlMem_free(vmsout);
11423 PerlMem_free(esa_out);
11424 set_vaxc_errno(sts);
11427 set_errno(ENOENT); break;
11429 set_errno(ENOTDIR); break;
11431 set_errno(ENODEV); break;
11433 set_errno(EINVAL); break;
11435 set_errno(EACCES); break;
11437 set_errno(EVMSERR);
11441 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
11442 if (preserve_dates & 2) {
11443 /* sys$close() will process xabrdt, not xabdat */
11444 xabrdt = cc$rms_xabrdt;
11446 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11448 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11449 * is unsigned long[2], while DECC & VAXC use a struct */
11450 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11452 fab_out.fab$l_xab = (void *) &xabrdt;
11455 ubf = PerlMem_malloc(32256);
11456 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11457 rab_in = cc$rms_rab;
11458 rab_in.rab$l_fab = &fab_in;
11459 rab_in.rab$l_rop = RAB$M_BIO;
11460 rab_in.rab$l_ubf = ubf;
11461 rab_in.rab$w_usz = 32256;
11462 if (!((sts = sys$connect(&rab_in)) & 1)) {
11463 sys$close(&fab_in); sys$close(&fab_out);
11464 PerlMem_free(vmsin);
11465 PerlMem_free(vmsout);
11469 PerlMem_free(esa_out);
11470 set_errno(EVMSERR); set_vaxc_errno(sts);
11474 rab_out = cc$rms_rab;
11475 rab_out.rab$l_fab = &fab_out;
11476 rab_out.rab$l_rbf = ubf;
11477 if (!((sts = sys$connect(&rab_out)) & 1)) {
11478 sys$close(&fab_in); sys$close(&fab_out);
11479 PerlMem_free(vmsin);
11480 PerlMem_free(vmsout);
11484 PerlMem_free(esa_out);
11485 set_errno(EVMSERR); set_vaxc_errno(sts);
11489 while ((sts = sys$read(&rab_in))) { /* always true */
11490 if (sts == RMS$_EOF) break;
11491 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11492 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11493 sys$close(&fab_in); sys$close(&fab_out);
11494 PerlMem_free(vmsin);
11495 PerlMem_free(vmsout);
11499 PerlMem_free(esa_out);
11500 set_errno(EVMSERR); set_vaxc_errno(sts);
11506 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
11507 sys$close(&fab_in); sys$close(&fab_out);
11508 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11510 PerlMem_free(vmsin);
11511 PerlMem_free(vmsout);
11515 PerlMem_free(esa_out);
11516 set_errno(EVMSERR); set_vaxc_errno(sts);
11520 PerlMem_free(vmsin);
11521 PerlMem_free(vmsout);
11525 PerlMem_free(esa_out);
11528 } /* end of rmscopy() */
11532 /*** The following glue provides 'hooks' to make some of the routines
11533 * from this file available from Perl. These routines are sufficiently
11534 * basic, and are required sufficiently early in the build process,
11535 * that's it's nice to have them available to miniperl as well as the
11536 * full Perl, so they're set up here instead of in an extension. The
11537 * Perl code which handles importation of these names into a given
11538 * package lives in [.VMS]Filespec.pm in @INC.
11542 rmsexpand_fromperl(pTHX_ CV *cv)
11545 char *fspec, *defspec = NULL, *rslt;
11547 int fs_utf8, dfs_utf8;
11551 if (!items || items > 2)
11552 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11553 fspec = SvPV(ST(0),n_a);
11554 fs_utf8 = SvUTF8(ST(0));
11555 if (!fspec || !*fspec) XSRETURN_UNDEF;
11557 defspec = SvPV(ST(1),n_a);
11558 dfs_utf8 = SvUTF8(ST(1));
11560 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11561 ST(0) = sv_newmortal();
11562 if (rslt != NULL) {
11563 sv_usepvn(ST(0),rslt,strlen(rslt));
11572 vmsify_fromperl(pTHX_ CV *cv)
11579 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11580 utf8_fl = SvUTF8(ST(0));
11581 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11582 ST(0) = sv_newmortal();
11583 if (vmsified != NULL) {
11584 sv_usepvn(ST(0),vmsified,strlen(vmsified));
11593 unixify_fromperl(pTHX_ CV *cv)
11600 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11601 utf8_fl = SvUTF8(ST(0));
11602 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11603 ST(0) = sv_newmortal();
11604 if (unixified != NULL) {
11605 sv_usepvn(ST(0),unixified,strlen(unixified));
11614 fileify_fromperl(pTHX_ CV *cv)
11621 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11622 utf8_fl = SvUTF8(ST(0));
11623 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11624 ST(0) = sv_newmortal();
11625 if (fileified != NULL) {
11626 sv_usepvn(ST(0),fileified,strlen(fileified));
11635 pathify_fromperl(pTHX_ CV *cv)
11642 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11643 utf8_fl = SvUTF8(ST(0));
11644 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11645 ST(0) = sv_newmortal();
11646 if (pathified != NULL) {
11647 sv_usepvn(ST(0),pathified,strlen(pathified));
11656 vmspath_fromperl(pTHX_ CV *cv)
11663 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11664 utf8_fl = SvUTF8(ST(0));
11665 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11666 ST(0) = sv_newmortal();
11667 if (vmspath != NULL) {
11668 sv_usepvn(ST(0),vmspath,strlen(vmspath));
11677 unixpath_fromperl(pTHX_ CV *cv)
11684 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11685 utf8_fl = SvUTF8(ST(0));
11686 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11687 ST(0) = sv_newmortal();
11688 if (unixpath != NULL) {
11689 sv_usepvn(ST(0),unixpath,strlen(unixpath));
11698 candelete_fromperl(pTHX_ CV *cv)
11706 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11708 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11709 Newx(fspec, VMS_MAXRSS, char);
11710 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11711 if (SvTYPE(mysv) == SVt_PVGV) {
11712 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11713 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11721 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11722 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11729 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11735 rmscopy_fromperl(pTHX_ CV *cv)
11738 char *inspec, *outspec, *inp, *outp;
11740 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11741 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11742 unsigned long int sts;
11747 if (items < 2 || items > 3)
11748 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11750 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11751 Newx(inspec, VMS_MAXRSS, char);
11752 if (SvTYPE(mysv) == SVt_PVGV) {
11753 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11754 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11762 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11763 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11769 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11770 Newx(outspec, VMS_MAXRSS, char);
11771 if (SvTYPE(mysv) == SVt_PVGV) {
11772 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11773 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11782 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11783 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11790 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11792 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11798 /* The mod2fname is limited to shorter filenames by design, so it should
11799 * not be modified to support longer EFS pathnames
11802 mod2fname(pTHX_ CV *cv)
11805 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11806 workbuff[NAM$C_MAXRSS*1 + 1];
11807 int total_namelen = 3, counter, num_entries;
11808 /* ODS-5 ups this, but we want to be consistent, so... */
11809 int max_name_len = 39;
11810 AV *in_array = (AV *)SvRV(ST(0));
11812 num_entries = av_len(in_array);
11814 /* All the names start with PL_. */
11815 strcpy(ultimate_name, "PL_");
11817 /* Clean up our working buffer */
11818 Zero(work_name, sizeof(work_name), char);
11820 /* Run through the entries and build up a working name */
11821 for(counter = 0; counter <= num_entries; counter++) {
11822 /* If it's not the first name then tack on a __ */
11824 strcat(work_name, "__");
11826 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11830 /* Check to see if we actually have to bother...*/
11831 if (strlen(work_name) + 3 <= max_name_len) {
11832 strcat(ultimate_name, work_name);
11834 /* It's too darned big, so we need to go strip. We use the same */
11835 /* algorithm as xsubpp does. First, strip out doubled __ */
11836 char *source, *dest, last;
11839 for (source = work_name; *source; source++) {
11840 if (last == *source && last == '_') {
11846 /* Go put it back */
11847 strcpy(work_name, workbuff);
11848 /* Is it still too big? */
11849 if (strlen(work_name) + 3 > max_name_len) {
11850 /* Strip duplicate letters */
11853 for (source = work_name; *source; source++) {
11854 if (last == toupper(*source)) {
11858 last = toupper(*source);
11860 strcpy(work_name, workbuff);
11863 /* Is it *still* too big? */
11864 if (strlen(work_name) + 3 > max_name_len) {
11865 /* Too bad, we truncate */
11866 work_name[max_name_len - 2] = 0;
11868 strcat(ultimate_name, work_name);
11871 /* Okay, return it */
11872 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11877 hushexit_fromperl(pTHX_ CV *cv)
11882 VMSISH_HUSHED = SvTRUE(ST(0));
11884 ST(0) = boolSV(VMSISH_HUSHED);
11890 Perl_vms_start_glob
11891 (pTHX_ SV *tmpglob,
11895 struct vs_str_st *rslt;
11899 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11902 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11903 struct dsc$descriptor_vs rsdsc;
11904 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11905 unsigned long hasver = 0, isunix = 0;
11906 unsigned long int lff_flags = 0;
11909 #ifdef VMS_LONGNAME_SUPPORT
11910 lff_flags = LIB$M_FIL_LONG_NAMES;
11912 /* The Newx macro will not allow me to assign a smaller array
11913 * to the rslt pointer, so we will assign it to the begin char pointer
11914 * and then copy the value into the rslt pointer.
11916 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11917 rslt = (struct vs_str_st *)begin;
11919 rstr = &rslt->str[0];
11920 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11921 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11922 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11923 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11925 Newx(vmsspec, VMS_MAXRSS, char);
11927 /* We could find out if there's an explicit dev/dir or version
11928 by peeking into lib$find_file's internal context at
11929 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11930 but that's unsupported, so I don't want to do it now and
11931 have it bite someone in the future. */
11932 /* Fix-me: vms_split_path() is the only way to do this, the
11933 existing method will fail with many legal EFS or UNIX specifications
11936 cp = SvPV(tmpglob,i);
11939 if (cp[i] == ';') hasver = 1;
11940 if (cp[i] == '.') {
11941 if (sts) hasver = 1;
11944 if (cp[i] == '/') {
11945 hasdir = isunix = 1;
11948 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11953 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11956 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11957 if (!stat_sts && S_ISDIR(st.st_mode)) {
11958 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11959 ok = (wilddsc.dsc$a_pointer != NULL);
11962 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11963 ok = (wilddsc.dsc$a_pointer != NULL);
11966 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11968 /* If not extended character set, replace ? with % */
11969 /* With extended character set, ? is a wildcard single character */
11970 if (!decc_efs_case_preserve) {
11971 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11972 if (*cp == '?') *cp = '%';
11975 while (ok && $VMS_STATUS_SUCCESS(sts)) {
11976 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11977 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11979 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11980 &dfltdsc,NULL,&rms_sts,&lff_flags);
11981 if (!$VMS_STATUS_SUCCESS(sts))
11984 /* with varying string, 1st word of buffer contains result length */
11985 rstr[rslt->length] = '\0';
11987 /* Find where all the components are */
11988 v_sts = vms_split_path
12003 /* If no version on input, truncate the version on output */
12004 if (!hasver && (vs_len > 0)) {
12008 /* No version & a null extension on UNIX handling */
12009 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12015 if (!decc_efs_case_preserve) {
12016 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12020 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12024 /* Start with the name */
12027 strcat(begin,"\n");
12028 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12030 if (cxt) (void)lib$find_file_end(&cxt);
12031 if (ok && sts != RMS$_NMF &&
12032 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12035 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12037 PerlIO_close(tmpfp);
12041 PerlIO_rewind(tmpfp);
12042 IoTYPE(io) = IoTYPE_RDONLY;
12043 IoIFP(io) = fp = tmpfp;
12044 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
12055 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
12058 vms_realpath_fromperl(pTHX_ CV *cv)
12061 char *fspec, *rslt_spec, *rslt;
12064 if (!items || items != 1)
12065 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12067 fspec = SvPV(ST(0),n_a);
12068 if (!fspec || !*fspec) XSRETURN_UNDEF;
12070 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12071 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12072 ST(0) = sv_newmortal();
12074 sv_usepvn(ST(0),rslt,strlen(rslt));
12076 Safefree(rslt_spec);
12081 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12082 int do_vms_case_tolerant(void);
12085 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12088 ST(0) = boolSV(do_vms_case_tolerant());
12094 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12095 struct interp_intern *dst)
12097 memcpy(dst,src,sizeof(struct interp_intern));
12101 Perl_sys_intern_clear(pTHX)
12106 Perl_sys_intern_init(pTHX)
12108 unsigned int ix = RAND_MAX;
12113 /* fix me later to track running under GNV */
12114 /* this allows some limited testing */
12115 MY_POSIX_EXIT = decc_filename_unix_report;
12118 MY_INV_RAND_MAX = 1./x;
12122 init_os_extras(void)
12125 char* file = __FILE__;
12126 if (decc_disable_to_vms_logname_translation) {
12127 no_translate_barewords = TRUE;
12129 no_translate_barewords = FALSE;
12132 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12133 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12134 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12135 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12136 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12137 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12138 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12139 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12140 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12141 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12142 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12144 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12146 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12147 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12150 store_pipelocs(aTHX); /* will redo any earlier attempts */
12157 #if __CRTL_VER == 80200000
12158 /* This missed getting in to the DECC SDK for 8.2 */
12159 char *realpath(const char *file_name, char * resolved_name, ...);
12162 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12163 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12164 * The perl fallback routine to provide realpath() is not as efficient
12168 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12170 return realpath(filespec, outbuf);
12174 /* External entry points */
12175 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12176 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12178 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12183 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12184 /* case_tolerant */
12186 /*{{{int do_vms_case_tolerant(void)*/
12187 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12188 * controlled by a process setting.
12190 int do_vms_case_tolerant(void)
12192 return vms_process_case_tolerant;
12195 /* External entry points */
12196 int Perl_vms_case_tolerant(void)
12197 { return do_vms_case_tolerant(); }
12199 int Perl_vms_case_tolerant(void)
12200 { return vms_process_case_tolerant; }
12204 /* Start of DECC RTL Feature handling */
12206 static int sys_trnlnm
12207 (const char * logname,
12211 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12212 const unsigned long attr = LNM$M_CASE_BLIND;
12213 struct dsc$descriptor_s name_dsc;
12215 unsigned short result;
12216 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12219 name_dsc.dsc$w_length = strlen(logname);
12220 name_dsc.dsc$a_pointer = (char *)logname;
12221 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12222 name_dsc.dsc$b_class = DSC$K_CLASS_S;
12224 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12226 if ($VMS_STATUS_SUCCESS(status)) {
12228 /* Null terminate and return the string */
12229 /*--------------------------------------*/
12236 static int sys_crelnm
12237 (const char * logname,
12238 const char * value)
12241 const char * proc_table = "LNM$PROCESS_TABLE";
12242 struct dsc$descriptor_s proc_table_dsc;
12243 struct dsc$descriptor_s logname_dsc;
12244 struct itmlst_3 item_list[2];
12246 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12247 proc_table_dsc.dsc$w_length = strlen(proc_table);
12248 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12249 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12251 logname_dsc.dsc$a_pointer = (char *) logname;
12252 logname_dsc.dsc$w_length = strlen(logname);
12253 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12254 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12256 item_list[0].buflen = strlen(value);
12257 item_list[0].itmcode = LNM$_STRING;
12258 item_list[0].bufadr = (char *)value;
12259 item_list[0].retlen = NULL;
12261 item_list[1].buflen = 0;
12262 item_list[1].itmcode = 0;
12264 ret_val = sys$crelnm
12266 (const struct dsc$descriptor_s *)&proc_table_dsc,
12267 (const struct dsc$descriptor_s *)&logname_dsc,
12269 (const struct item_list_3 *) item_list);
12274 /* C RTL Feature settings */
12276 static int set_features
12277 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
12278 int (* cli_routine)(void), /* Not documented */
12279 void *image_info) /* Not documented */
12286 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12287 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12288 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12289 unsigned long case_perm;
12290 unsigned long case_image;
12293 /* Allow an exception to bring Perl into the VMS debugger */
12294 vms_debug_on_exception = 0;
12295 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12296 if ($VMS_STATUS_SUCCESS(status)) {
12297 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12298 vms_debug_on_exception = 1;
12300 vms_debug_on_exception = 0;
12303 /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12304 vms_vtf7_filenames = 0;
12305 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12306 if ($VMS_STATUS_SUCCESS(status)) {
12307 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12308 vms_vtf7_filenames = 1;
12310 vms_vtf7_filenames = 0;
12313 /* Dectect running under GNV Bash or other UNIX like shell */
12314 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12315 gnv_unix_shell = 0;
12316 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12317 if ($VMS_STATUS_SUCCESS(status)) {
12318 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12319 gnv_unix_shell = 1;
12320 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12321 set_feature_default("DECC$EFS_CHARSET", 1);
12322 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12323 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12324 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12325 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12328 gnv_unix_shell = 0;
12332 /* hacks to see if known bugs are still present for testing */
12334 /* Readdir is returning filenames in VMS syntax always */
12335 decc_bug_readdir_efs1 = 1;
12336 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12337 if ($VMS_STATUS_SUCCESS(status)) {
12338 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12339 decc_bug_readdir_efs1 = 1;
12341 decc_bug_readdir_efs1 = 0;
12344 /* PCP mode requires creating /dev/null special device file */
12345 decc_bug_devnull = 0;
12346 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12347 if ($VMS_STATUS_SUCCESS(status)) {
12348 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12349 decc_bug_devnull = 1;
12351 decc_bug_devnull = 0;
12354 /* fgetname returning a VMS name in UNIX mode */
12355 decc_bug_fgetname = 1;
12356 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12357 if ($VMS_STATUS_SUCCESS(status)) {
12358 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12359 decc_bug_fgetname = 1;
12361 decc_bug_fgetname = 0;
12364 /* UNIX directory names with no paths are broken in a lot of places */
12365 decc_dir_barename = 1;
12366 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12367 if ($VMS_STATUS_SUCCESS(status)) {
12368 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12369 decc_dir_barename = 1;
12371 decc_dir_barename = 0;
12374 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12375 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12377 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12378 if (decc_disable_to_vms_logname_translation < 0)
12379 decc_disable_to_vms_logname_translation = 0;
12382 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12384 decc_efs_case_preserve = decc$feature_get_value(s, 1);
12385 if (decc_efs_case_preserve < 0)
12386 decc_efs_case_preserve = 0;
12389 s = decc$feature_get_index("DECC$EFS_CHARSET");
12391 decc_efs_charset = decc$feature_get_value(s, 1);
12392 if (decc_efs_charset < 0)
12393 decc_efs_charset = 0;
12396 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12398 decc_filename_unix_report = decc$feature_get_value(s, 1);
12399 if (decc_filename_unix_report > 0)
12400 decc_filename_unix_report = 1;
12402 decc_filename_unix_report = 0;
12405 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12407 decc_filename_unix_only = decc$feature_get_value(s, 1);
12408 if (decc_filename_unix_only > 0) {
12409 decc_filename_unix_only = 1;
12412 decc_filename_unix_only = 0;
12416 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12418 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12419 if (decc_filename_unix_no_version < 0)
12420 decc_filename_unix_no_version = 0;
12423 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12425 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12426 if (decc_readdir_dropdotnotype < 0)
12427 decc_readdir_dropdotnotype = 0;
12430 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12431 if ($VMS_STATUS_SUCCESS(status)) {
12432 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12434 dflt = decc$feature_get_value(s, 4);
12436 decc_disable_posix_root = decc$feature_get_value(s, 1);
12437 if (decc_disable_posix_root <= 0) {
12438 decc$feature_set_value(s, 1, 1);
12439 decc_disable_posix_root = 1;
12443 /* Traditionally Perl assumes this is off */
12444 decc_disable_posix_root = 1;
12445 decc$feature_set_value(s, 1, 1);
12450 #if __CRTL_VER >= 80200000
12451 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12453 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12454 if (decc_posix_compliant_pathnames < 0)
12455 decc_posix_compliant_pathnames = 0;
12456 if (decc_posix_compliant_pathnames > 4)
12457 decc_posix_compliant_pathnames = 0;
12462 status = sys_trnlnm
12463 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12464 if ($VMS_STATUS_SUCCESS(status)) {
12465 val_str[0] = _toupper(val_str[0]);
12466 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12467 decc_disable_to_vms_logname_translation = 1;
12472 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12473 if ($VMS_STATUS_SUCCESS(status)) {
12474 val_str[0] = _toupper(val_str[0]);
12475 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12476 decc_efs_case_preserve = 1;
12481 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12482 if ($VMS_STATUS_SUCCESS(status)) {
12483 val_str[0] = _toupper(val_str[0]);
12484 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12485 decc_filename_unix_report = 1;
12488 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12489 if ($VMS_STATUS_SUCCESS(status)) {
12490 val_str[0] = _toupper(val_str[0]);
12491 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12492 decc_filename_unix_only = 1;
12493 decc_filename_unix_report = 1;
12496 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12497 if ($VMS_STATUS_SUCCESS(status)) {
12498 val_str[0] = _toupper(val_str[0]);
12499 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12500 decc_filename_unix_no_version = 1;
12503 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12504 if ($VMS_STATUS_SUCCESS(status)) {
12505 val_str[0] = _toupper(val_str[0]);
12506 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12507 decc_readdir_dropdotnotype = 1;
12512 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12514 /* Report true case tolerance */
12515 /*----------------------------*/
12516 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12517 if (!$VMS_STATUS_SUCCESS(status))
12518 case_perm = PPROP$K_CASE_BLIND;
12519 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12520 if (!$VMS_STATUS_SUCCESS(status))
12521 case_image = PPROP$K_CASE_BLIND;
12522 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12523 (case_image == PPROP$K_CASE_SENSITIVE))
12524 vms_process_case_tolerant = 0;
12529 /* CRTL can be initialized past this point, but not before. */
12530 /* DECC$CRTL_INIT(); */
12536 /* DECC dependent attributes */
12537 #if __DECC_VER < 60560002
12539 #define not_executable
12541 #define relative ,rel
12542 #define not_executable ,noexe
12545 #pragma extern_model save
12546 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12548 const __align (LONGWORD) int spare[8] = {0};
12549 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
12552 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
12553 nowrt,noshr relative not_executable
12555 const long vms_cc_features = (const long)set_features;
12558 ** Force a reference to LIB$INITIALIZE to ensure it
12559 ** exists in the image.
12561 int lib$initialize(void);
12563 #pragma extern_model strict_refdef
12565 int lib_init_ref = (int) lib$initialize;
12568 #pragma extern_model restore