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 #if __CRTL_VER >= 70300000 && !defined(__VAX)
96 static int set_feature_default(const char *name, int value)
101 index = decc$feature_get_index(name);
103 status = decc$feature_set_value(index, 1, value);
104 if (index == -1 || (status == -1)) {
108 status = decc$feature_get_value(index, 1);
109 if (status != value) {
117 /* Older versions of ssdef.h don't have these */
118 #ifndef SS$_INVFILFOROP
119 # define SS$_INVFILFOROP 3930
121 #ifndef SS$_NOSUCHOBJECT
122 # define SS$_NOSUCHOBJECT 2696
125 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
126 #define PERLIO_NOT_STDIO 0
128 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
129 * code below needs to get to the underlying CRTL routines. */
130 #define DONT_MASK_RTL_CALLS
134 /* Anticipating future expansion in lexical warnings . . . */
135 #ifndef WARN_INTERNAL
136 # define WARN_INTERNAL WARN_MISC
139 #ifdef VMS_LONGNAME_SUPPORT
140 #include <libfildef.h>
143 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
144 # define RTL_USES_UTC 1
147 #ifdef USE_VMS_DECTERM
149 /* Routine to create a decterm for use with the Perl debugger */
150 /* No headers, this information was found in the Programming Concepts Manual */
153 (const struct dsc$descriptor_s * display,
154 const struct dsc$descriptor_s * setup_file,
155 const struct dsc$descriptor_s * customization,
156 struct dsc$descriptor_s * result_device_name,
157 unsigned short * result_device_name_length,
160 void * char_change_buffer);
163 /* gcc's header files don't #define direct access macros
164 * corresponding to VAXC's variant structs */
166 # define uic$v_format uic$r_uic_form.uic$v_format
167 # define uic$v_group uic$r_uic_form.uic$v_group
168 # define uic$v_member uic$r_uic_form.uic$v_member
169 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
170 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
171 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
172 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
175 #if defined(NEED_AN_H_ERRNO)
180 #pragma message disable pragma
181 #pragma member_alignment save
182 #pragma nomember_alignment longword
184 #pragma message disable misalgndmem
187 unsigned short int buflen;
188 unsigned short int itmcode;
190 unsigned short int *retlen;
193 struct filescan_itmlst_2 {
194 unsigned short length;
195 unsigned short itmcode;
200 unsigned short length;
205 #pragma message restore
206 #pragma member_alignment restore
209 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
210 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
211 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
212 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
213 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
214 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
215 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
216 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
217 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
218 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
219 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
221 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
222 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
223 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
224 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
226 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
227 #define PERL_LNM_MAX_ALLOWED_INDEX 127
229 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
230 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
233 #define PERL_LNM_MAX_ITER 10
235 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
236 #if __CRTL_VER >= 70302000 && !defined(__VAX)
237 #define MAX_DCL_SYMBOL (8192)
238 #define MAX_DCL_LINE_LENGTH (4096 - 4)
240 #define MAX_DCL_SYMBOL (1024)
241 #define MAX_DCL_LINE_LENGTH (1024 - 4)
244 static char *__mystrtolower(char *str)
246 if (str) for (; *str; ++str) *str= tolower(*str);
250 static struct dsc$descriptor_s fildevdsc =
251 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
252 static struct dsc$descriptor_s crtlenvdsc =
253 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
254 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
255 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
256 static struct dsc$descriptor_s **env_tables = defenv;
257 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
259 /* True if we shouldn't treat barewords as logicals during directory */
261 static int no_translate_barewords;
264 static int tz_updated = 1;
267 /* DECC Features that may need to affect how Perl interprets
268 * displays filename information
270 static int decc_disable_to_vms_logname_translation = 1;
271 static int decc_disable_posix_root = 1;
272 int decc_efs_case_preserve = 0;
273 static int decc_efs_charset = 0;
274 static int decc_filename_unix_no_version = 0;
275 static int decc_filename_unix_only = 0;
276 int decc_filename_unix_report = 0;
277 int decc_posix_compliant_pathnames = 0;
278 int decc_readdir_dropdotnotype = 0;
279 static int vms_process_case_tolerant = 1;
280 int vms_vtf7_filenames = 0;
281 int gnv_unix_shell = 0;
283 /* bug workarounds if needed */
284 int decc_bug_readdir_efs1 = 0;
285 int decc_bug_devnull = 1;
286 int decc_bug_fgetname = 0;
287 int decc_dir_barename = 0;
289 static int vms_debug_on_exception = 0;
291 /* Is this a UNIX file specification?
292 * No longer a simple check with EFS file specs
293 * For now, not a full check, but need to
294 * handle POSIX ^UP^ specifications
295 * Fixing to handle ^/ cases would require
296 * changes to many other conversion routines.
299 static int is_unix_filespec(const char *path)
305 if (strncmp(path,"\"^UP^",5) != 0) {
306 pch1 = strchr(path, '/');
311 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
312 if (decc_filename_unix_report || decc_filename_unix_only) {
313 if (strcmp(path,".") == 0)
321 /* This routine converts a UCS-2 character to be VTF-7 encoded.
324 static void ucs2_to_vtf7
326 unsigned long ucs2_char,
329 unsigned char * ucs_ptr;
332 ucs_ptr = (unsigned char *)&ucs2_char;
336 hex = (ucs_ptr[1] >> 4) & 0xf;
338 outspec[2] = hex + '0';
340 outspec[2] = (hex - 9) + 'A';
341 hex = ucs_ptr[1] & 0xF;
343 outspec[3] = hex + '0';
345 outspec[3] = (hex - 9) + 'A';
347 hex = (ucs_ptr[0] >> 4) & 0xf;
349 outspec[4] = hex + '0';
351 outspec[4] = (hex - 9) + 'A';
352 hex = ucs_ptr[1] & 0xF;
354 outspec[5] = hex + '0';
356 outspec[5] = (hex - 9) + 'A';
362 /* This handles the conversion of a UNIX extended character set to a ^
363 * escaped VMS character.
364 * in a UNIX file specification.
366 * The output count variable contains the number of characters added
367 * to the output string.
369 * The return value is the number of characters read from the input string
371 static int copy_expand_unix_filename_escape
372 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
380 utf8_flag = *utf8_fl;
384 if (*inspec >= 0x80) {
385 if (utf8_fl && vms_vtf7_filenames) {
386 unsigned long ucs_char;
390 if ((*inspec & 0xE0) == 0xC0) {
392 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
393 if (ucs_char >= 0x80) {
394 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
397 } else if ((*inspec & 0xF0) == 0xE0) {
399 ucs_char = ((inspec[0] & 0xF) << 12) +
400 ((inspec[1] & 0x3f) << 6) +
402 if (ucs_char >= 0x800) {
403 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
407 #if 0 /* I do not see longer sequences supported by OpenVMS */
408 /* Maybe some one can fix this later */
409 } else if ((*inspec & 0xF8) == 0xF0) {
412 } else if ((*inspec & 0xFC) == 0xF8) {
415 } else if ((*inspec & 0xFE) == 0xFC) {
422 /* High bit set, but not a unicode character! */
424 /* Non printing DECMCS or ISO Latin-1 character? */
425 if (*inspec <= 0x9F) {
429 hex = (*inspec >> 4) & 0xF;
431 outspec[1] = hex + '0';
433 outspec[1] = (hex - 9) + 'A';
437 outspec[2] = hex + '0';
439 outspec[2] = (hex - 9) + 'A';
443 } else if (*inspec == 0xA0) {
449 } else if (*inspec == 0xFF) {
461 /* Is this a macro that needs to be passed through?
462 * Macros start with $( and an alpha character, followed
463 * by a string of alpha numeric characters ending with a )
464 * If this does not match, then encode it as ODS-5.
466 if ((inspec[0] == '$') && (inspec[1] == '(')) {
469 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
471 outspec[0] = inspec[0];
472 outspec[1] = inspec[1];
473 outspec[2] = inspec[2];
475 while(isalnum(inspec[tcnt]) ||
476 (inspec[2] == '.') || (inspec[2] == '_')) {
477 outspec[tcnt] = inspec[tcnt];
480 if (inspec[tcnt] == ')') {
481 outspec[tcnt] = inspec[tcnt];
498 if (decc_efs_charset == 0)
525 /* Assume that this is to be escaped */
527 outspec[1] = *inspec;
531 case ' ': /* space */
532 /* Assume that this is to be escaped */
547 /* This handles the expansion of a '^' prefix to the proper character
548 * in a UNIX file specification.
550 * The output count variable contains the number of characters added
551 * to the output string.
553 * The return value is the number of characters read from the input
556 static int copy_expand_vms_filename_escape
557 (char *outspec, const char *inspec, int *output_cnt)
564 if (*inspec == '^') {
568 /* Non trailing dots should just be passed through */
573 case '_': /* space */
579 case 'U': /* Unicode - FIX-ME this is wrong. */
582 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
585 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
586 outspec[0] == c1 & 0xff;
587 outspec[1] == c2 & 0xff;
594 /* Error - do best we can to continue */
604 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
608 scnt = sscanf(inspec, "%2x", &c1);
609 outspec[0] = c1 & 0xff;
632 (const struct dsc$descriptor_s * srcstr,
633 struct filescan_itmlst_2 * valuelist,
634 unsigned long * fldflags,
635 struct dsc$descriptor_s *auxout,
636 unsigned short * retlen);
638 /* vms_split_path - Verify that the input file specification is a
639 * VMS format file specification, and provide pointers to the components of
640 * it. With EFS format filenames, this is virtually the only way to
641 * parse a VMS path specification into components.
643 * If the sum of the components do not add up to the length of the
644 * string, then the passed file specification is probably a UNIX style
647 static int vms_split_path
662 struct dsc$descriptor path_desc;
666 struct filescan_itmlst_2 item_list[9];
667 const int filespec = 0;
668 const int nodespec = 1;
669 const int devspec = 2;
670 const int rootspec = 3;
671 const int dirspec = 4;
672 const int namespec = 5;
673 const int typespec = 6;
674 const int verspec = 7;
676 /* Assume the worst for an easy exit */
691 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
692 path_desc.dsc$w_length = strlen(path);
693 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
694 path_desc.dsc$b_class = DSC$K_CLASS_S;
696 /* Get the total length, if it is shorter than the string passed
697 * then this was probably not a VMS formatted file specification
699 item_list[filespec].itmcode = FSCN$_FILESPEC;
700 item_list[filespec].length = 0;
701 item_list[filespec].component = NULL;
703 /* If the node is present, then it gets considered as part of the
704 * volume name to hopefully make things simple.
706 item_list[nodespec].itmcode = FSCN$_NODE;
707 item_list[nodespec].length = 0;
708 item_list[nodespec].component = NULL;
710 item_list[devspec].itmcode = FSCN$_DEVICE;
711 item_list[devspec].length = 0;
712 item_list[devspec].component = NULL;
714 /* root is a special case, adding it to either the directory or
715 * the device components will probalby complicate things for the
716 * callers of this routine, so leave it separate.
718 item_list[rootspec].itmcode = FSCN$_ROOT;
719 item_list[rootspec].length = 0;
720 item_list[rootspec].component = NULL;
722 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
723 item_list[dirspec].length = 0;
724 item_list[dirspec].component = NULL;
726 item_list[namespec].itmcode = FSCN$_NAME;
727 item_list[namespec].length = 0;
728 item_list[namespec].component = NULL;
730 item_list[typespec].itmcode = FSCN$_TYPE;
731 item_list[typespec].length = 0;
732 item_list[typespec].component = NULL;
734 item_list[verspec].itmcode = FSCN$_VERSION;
735 item_list[verspec].length = 0;
736 item_list[verspec].component = NULL;
738 item_list[8].itmcode = 0;
739 item_list[8].length = 0;
740 item_list[8].component = NULL;
742 status = SYS$FILESCAN
743 ((const struct dsc$descriptor_s *)&path_desc, item_list,
745 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
747 /* If we parsed it successfully these two lengths should be the same */
748 if (path_desc.dsc$w_length != item_list[filespec].length)
751 /* If we got here, then it is a VMS file specification */
754 /* set the volume name */
755 if (item_list[nodespec].length > 0) {
756 *volume = item_list[nodespec].component;
757 *vol_len = item_list[nodespec].length + item_list[devspec].length;
760 *volume = item_list[devspec].component;
761 *vol_len = item_list[devspec].length;
764 *root = item_list[rootspec].component;
765 *root_len = item_list[rootspec].length;
767 *dir = item_list[dirspec].component;
768 *dir_len = item_list[dirspec].length;
770 /* Now fun with versions and EFS file specifications
771 * The parser can not tell the difference when a "." is a version
772 * delimiter or a part of the file specification.
774 if ((decc_efs_charset) &&
775 (item_list[verspec].length > 0) &&
776 (item_list[verspec].component[0] == '.')) {
777 *name = item_list[namespec].component;
778 *name_len = item_list[namespec].length + item_list[typespec].length;
779 *ext = item_list[verspec].component;
780 *ext_len = item_list[verspec].length;
785 *name = item_list[namespec].component;
786 *name_len = item_list[namespec].length;
787 *ext = item_list[typespec].component;
788 *ext_len = item_list[typespec].length;
789 *version = item_list[verspec].component;
790 *ver_len = item_list[verspec].length;
797 * Routine to retrieve the maximum equivalence index for an input
798 * logical name. Some calls to this routine have no knowledge if
799 * the variable is a logical or not. So on error we return a max
802 /*{{{int my_maxidx(const char *lnm) */
804 my_maxidx(const char *lnm)
808 int attr = LNM$M_CASE_BLIND;
809 struct dsc$descriptor lnmdsc;
810 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
813 lnmdsc.dsc$w_length = strlen(lnm);
814 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
815 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
816 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
818 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
819 if ((status & 1) == 0)
826 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
828 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
829 struct dsc$descriptor_s **tabvec, unsigned long int flags)
832 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
833 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
834 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
836 unsigned char acmode;
837 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
838 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
839 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
840 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
842 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
843 #if defined(PERL_IMPLICIT_CONTEXT)
846 aTHX = PERL_GET_INTERP;
852 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
853 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
855 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
856 *cp2 = _toupper(*cp1);
857 if (cp1 - lnm > LNM$C_NAMLENGTH) {
858 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
862 lnmdsc.dsc$w_length = cp1 - lnm;
863 lnmdsc.dsc$a_pointer = uplnm;
864 uplnm[lnmdsc.dsc$w_length] = '\0';
865 secure = flags & PERL__TRNENV_SECURE;
866 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
867 if (!tabvec || !*tabvec) tabvec = env_tables;
869 for (curtab = 0; tabvec[curtab]; curtab++) {
870 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
871 if (!ivenv && !secure) {
876 Perl_warn(aTHX_ "Can't read CRTL environ\n");
879 retsts = SS$_NOLOGNAM;
880 for (i = 0; environ[i]; i++) {
881 if ((eq = strchr(environ[i],'=')) &&
882 lnmdsc.dsc$w_length == (eq - environ[i]) &&
883 !strncmp(environ[i],uplnm,eq - environ[i])) {
885 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
886 if (!eqvlen) continue;
891 if (retsts != SS$_NOLOGNAM) break;
894 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
895 !str$case_blind_compare(&tmpdsc,&clisym)) {
896 if (!ivsym && !secure) {
897 unsigned short int deflen = LNM$C_NAMLENGTH;
898 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
899 /* dynamic dsc to accomodate possible long value */
900 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
901 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
903 if (eqvlen > MAX_DCL_SYMBOL) {
904 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
905 eqvlen = MAX_DCL_SYMBOL;
906 /* Special hack--we might be called before the interpreter's */
907 /* fully initialized, in which case either thr or PL_curcop */
908 /* might be bogus. We have to check, since ckWARN needs them */
909 /* both to be valid if running threaded */
910 if (ckWARN(WARN_MISC)) {
911 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
914 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
916 _ckvmssts(lib$sfree1_dd(&eqvdsc));
917 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
918 if (retsts == LIB$_NOSUCHSYM) continue;
923 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
924 midx = my_maxidx(lnm);
925 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
926 lnmlst[1].bufadr = cp2;
928 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
929 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
930 if (retsts == SS$_NOLOGNAM) break;
931 /* PPFs have a prefix */
934 *((int *)uplnm) == *((int *)"SYS$") &&
936 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
937 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
938 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
939 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
940 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
941 memmove(eqv,eqv+4,eqvlen-4);
947 if ((retsts == SS$_IVLOGNAM) ||
948 (retsts == SS$_NOLOGNAM)) { continue; }
951 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
952 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
953 if (retsts == SS$_NOLOGNAM) continue;
956 eqvlen = strlen(eqv);
960 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
961 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
962 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
963 retsts == SS$_NOLOGNAM) {
964 set_errno(EINVAL); set_vaxc_errno(retsts);
966 else _ckvmssts(retsts);
968 } /* end of vmstrnenv */
971 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
972 /* Define as a function so we can access statics. */
973 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
975 return vmstrnenv(lnm,eqv,idx,fildev,
976 #ifdef SECURE_INTERNAL_GETENV
977 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
986 * Note: Uses Perl temp to store result so char * can be returned to
987 * caller; this pointer will be invalidated at next Perl statement
989 * We define this as a function rather than a macro in terms of my_getenv_len()
990 * so that it'll work when PL_curinterp is undefined (and we therefore can't
993 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
995 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
998 static char *__my_getenv_eqv = NULL;
999 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1000 unsigned long int idx = 0;
1001 int trnsuccess, success, secure, saverr, savvmserr;
1005 midx = my_maxidx(lnm) + 1;
1007 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1008 /* Set up a temporary buffer for the return value; Perl will
1009 * clean it up at the next statement transition */
1010 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1011 if (!tmpsv) return NULL;
1015 /* Assume no interpreter ==> single thread */
1016 if (__my_getenv_eqv != NULL) {
1017 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1020 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1022 eqv = __my_getenv_eqv;
1025 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1026 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1028 getcwd(eqv,LNM$C_NAMLENGTH);
1032 /* Get rid of "000000/ in rooted filespecs */
1035 zeros = strstr(eqv, "/000000/");
1036 if (zeros != NULL) {
1038 mlen = len - (zeros - eqv) - 7;
1039 memmove(zeros, &zeros[7], mlen);
1047 /* Impose security constraints only if tainting */
1049 /* Impose security constraints only if tainting */
1050 secure = PL_curinterp ? PL_tainting : will_taint;
1051 saverr = errno; savvmserr = vaxc$errno;
1058 #ifdef SECURE_INTERNAL_GETENV
1059 secure ? PERL__TRNENV_SECURE : 0
1065 /* For the getenv interface we combine all the equivalence names
1066 * of a search list logical into one value to acquire a maximum
1067 * value length of 255*128 (assuming %ENV is using logicals).
1069 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1071 /* If the name contains a semicolon-delimited index, parse it
1072 * off and make sure we only retrieve the equivalence name for
1074 if ((cp2 = strchr(lnm,';')) != NULL) {
1076 uplnm[cp2-lnm] = '\0';
1077 idx = strtoul(cp2+1,NULL,0);
1079 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1082 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1084 /* Discard NOLOGNAM on internal calls since we're often looking
1085 * for an optional name, and this "error" often shows up as the
1086 * (bogus) exit status for a die() call later on. */
1087 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1088 return success ? eqv : Nullch;
1091 } /* end of my_getenv() */
1095 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1097 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1101 unsigned long idx = 0;
1103 static char *__my_getenv_len_eqv = NULL;
1104 int secure, saverr, savvmserr;
1107 midx = my_maxidx(lnm) + 1;
1109 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1110 /* Set up a temporary buffer for the return value; Perl will
1111 * clean it up at the next statement transition */
1112 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1113 if (!tmpsv) return NULL;
1117 /* Assume no interpreter ==> single thread */
1118 if (__my_getenv_len_eqv != NULL) {
1119 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1122 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1124 buf = __my_getenv_len_eqv;
1127 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1128 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1131 getcwd(buf,LNM$C_NAMLENGTH);
1134 /* Get rid of "000000/ in rooted filespecs */
1136 zeros = strstr(buf, "/000000/");
1137 if (zeros != NULL) {
1139 mlen = *len - (zeros - buf) - 7;
1140 memmove(zeros, &zeros[7], mlen);
1149 /* Impose security constraints only if tainting */
1150 secure = PL_curinterp ? PL_tainting : will_taint;
1151 saverr = errno; savvmserr = vaxc$errno;
1158 #ifdef SECURE_INTERNAL_GETENV
1159 secure ? PERL__TRNENV_SECURE : 0
1165 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1167 if ((cp2 = strchr(lnm,';')) != NULL) {
1169 buf[cp2-lnm] = '\0';
1170 idx = strtoul(cp2+1,NULL,0);
1172 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1175 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1177 /* Get rid of "000000/ in rooted filespecs */
1180 zeros = strstr(buf, "/000000/");
1181 if (zeros != NULL) {
1183 mlen = *len - (zeros - buf) - 7;
1184 memmove(zeros, &zeros[7], mlen);
1190 /* Discard NOLOGNAM on internal calls since we're often looking
1191 * for an optional name, and this "error" often shows up as the
1192 * (bogus) exit status for a die() call later on. */
1193 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1194 return *len ? buf : Nullch;
1197 } /* end of my_getenv_len() */
1200 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1202 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1204 /*{{{ void prime_env_iter() */
1206 prime_env_iter(void)
1207 /* Fill the %ENV associative array with all logical names we can
1208 * find, in preparation for iterating over it.
1211 static int primed = 0;
1212 HV *seenhv = NULL, *envhv;
1214 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1215 unsigned short int chan;
1216 #ifndef CLI$M_TRUSTED
1217 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1219 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1220 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1222 bool have_sym = FALSE, have_lnm = FALSE;
1223 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1224 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1225 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1226 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1227 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1228 #if defined(PERL_IMPLICIT_CONTEXT)
1231 #if defined(USE_ITHREADS)
1232 static perl_mutex primenv_mutex;
1233 MUTEX_INIT(&primenv_mutex);
1236 #if defined(PERL_IMPLICIT_CONTEXT)
1237 /* We jump through these hoops because we can be called at */
1238 /* platform-specific initialization time, which is before anything is */
1239 /* set up--we can't even do a plain dTHX since that relies on the */
1240 /* interpreter structure to be initialized */
1242 aTHX = PERL_GET_INTERP;
1248 if (primed || !PL_envgv) return;
1249 MUTEX_LOCK(&primenv_mutex);
1250 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1251 envhv = GvHVn(PL_envgv);
1252 /* Perform a dummy fetch as an lval to insure that the hash table is
1253 * set up. Otherwise, the hv_store() will turn into a nullop. */
1254 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1256 for (i = 0; env_tables[i]; i++) {
1257 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1258 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1259 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1261 if (have_sym || have_lnm) {
1262 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1263 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1264 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1265 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1268 for (i--; i >= 0; i--) {
1269 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1272 for (j = 0; environ[j]; j++) {
1273 if (!(start = strchr(environ[j],'='))) {
1274 if (ckWARN(WARN_INTERNAL))
1275 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1279 sv = newSVpv(start,0);
1281 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1286 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1287 !str$case_blind_compare(&tmpdsc,&clisym)) {
1288 strcpy(cmd,"Show Symbol/Global *");
1289 cmddsc.dsc$w_length = 20;
1290 if (env_tables[i]->dsc$w_length == 12 &&
1291 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1292 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1293 flags = defflags | CLI$M_NOLOGNAM;
1296 strcpy(cmd,"Show Logical *");
1297 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1298 strcat(cmd," /Table=");
1299 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1300 cmddsc.dsc$w_length = strlen(cmd);
1302 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1303 flags = defflags | CLI$M_NOCLISYM;
1306 /* Create a new subprocess to execute each command, to exclude the
1307 * remote possibility that someone could subvert a mbx or file used
1308 * to write multiple commands to a single subprocess.
1311 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1312 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1313 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1314 defflags &= ~CLI$M_TRUSTED;
1315 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1317 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1318 if (seenhv) SvREFCNT_dec(seenhv);
1321 char *cp1, *cp2, *key;
1322 unsigned long int sts, iosb[2], retlen, keylen;
1325 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1326 if (sts & 1) sts = iosb[0] & 0xffff;
1327 if (sts == SS$_ENDOFFILE) {
1329 while (substs == 0) { sys$hiber(); wakect++;}
1330 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1335 retlen = iosb[0] >> 16;
1336 if (!retlen) continue; /* blank line */
1338 if (iosb[1] != subpid) {
1340 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1344 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1345 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1347 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1348 if (*cp1 == '(' || /* Logical name table name */
1349 *cp1 == '=' /* Next eqv of searchlist */) continue;
1350 if (*cp1 == '"') cp1++;
1351 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1352 key = cp1; keylen = cp2 - cp1;
1353 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1354 while (*cp2 && *cp2 != '=') cp2++;
1355 while (*cp2 && *cp2 == '=') cp2++;
1356 while (*cp2 && *cp2 == ' ') cp2++;
1357 if (*cp2 == '"') { /* String translation; may embed "" */
1358 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1359 cp2++; cp1--; /* Skip "" surrounding translation */
1361 else { /* Numeric translation */
1362 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1363 cp1--; /* stop on last non-space char */
1365 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1366 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1369 PERL_HASH(hash,key,keylen);
1371 if (cp1 == cp2 && *cp2 == '.') {
1372 /* A single dot usually means an unprintable character, such as a null
1373 * to indicate a zero-length value. Get the actual value to make sure.
1375 char lnm[LNM$C_NAMLENGTH+1];
1376 char eqv[MAX_DCL_SYMBOL+1];
1378 strncpy(lnm, key, keylen);
1379 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1380 sv = newSVpvn(eqv, strlen(eqv));
1383 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1387 hv_store(envhv,key,keylen,sv,hash);
1388 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1390 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1391 /* get the PPFs for this process, not the subprocess */
1392 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1393 char eqv[LNM$C_NAMLENGTH+1];
1395 for (i = 0; ppfs[i]; i++) {
1396 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1397 sv = newSVpv(eqv,trnlen);
1399 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1404 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1405 if (buf) Safefree(buf);
1406 if (seenhv) SvREFCNT_dec(seenhv);
1407 MUTEX_UNLOCK(&primenv_mutex);
1410 } /* end of prime_env_iter */
1414 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1415 /* Define or delete an element in the same "environment" as
1416 * vmstrnenv(). If an element is to be deleted, it's removed from
1417 * the first place it's found. If it's to be set, it's set in the
1418 * place designated by the first element of the table vector.
1419 * Like setenv() returns 0 for success, non-zero on error.
1422 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1425 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1426 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1428 unsigned long int retsts, usermode = PSL$C_USER;
1429 struct itmlst_3 *ile, *ilist;
1430 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1431 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1432 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1433 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1434 $DESCRIPTOR(local,"_LOCAL");
1437 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1438 return SS$_IVLOGNAM;
1441 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1442 *cp2 = _toupper(*cp1);
1443 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1444 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1445 return SS$_IVLOGNAM;
1448 lnmdsc.dsc$w_length = cp1 - lnm;
1449 if (!tabvec || !*tabvec) tabvec = env_tables;
1451 if (!eqv) { /* we're deleting n element */
1452 for (curtab = 0; tabvec[curtab]; curtab++) {
1453 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1455 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1456 if ((cp1 = strchr(environ[i],'=')) &&
1457 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1458 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1460 return setenv(lnm,"",1) ? vaxc$errno : 0;
1463 ivenv = 1; retsts = SS$_NOLOGNAM;
1465 if (ckWARN(WARN_INTERNAL))
1466 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1467 ivenv = 1; retsts = SS$_NOSUCHPGM;
1473 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1474 !str$case_blind_compare(&tmpdsc,&clisym)) {
1475 unsigned int symtype;
1476 if (tabvec[curtab]->dsc$w_length == 12 &&
1477 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1478 !str$case_blind_compare(&tmpdsc,&local))
1479 symtype = LIB$K_CLI_LOCAL_SYM;
1480 else symtype = LIB$K_CLI_GLOBAL_SYM;
1481 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1482 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1483 if (retsts == LIB$_NOSUCHSYM) continue;
1487 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1488 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1489 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1490 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1491 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1495 else { /* we're defining a value */
1496 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1498 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1500 if (ckWARN(WARN_INTERNAL))
1501 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1502 retsts = SS$_NOSUCHPGM;
1506 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1507 eqvdsc.dsc$w_length = strlen(eqv);
1508 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1509 !str$case_blind_compare(&tmpdsc,&clisym)) {
1510 unsigned int symtype;
1511 if (tabvec[0]->dsc$w_length == 12 &&
1512 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1513 !str$case_blind_compare(&tmpdsc,&local))
1514 symtype = LIB$K_CLI_LOCAL_SYM;
1515 else symtype = LIB$K_CLI_GLOBAL_SYM;
1516 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1519 if (!*eqv) eqvdsc.dsc$w_length = 1;
1520 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1522 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1523 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1524 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1525 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1526 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1527 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1530 Newx(ilist,nseg+1,struct itmlst_3);
1533 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1536 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1538 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1539 ile->itmcode = LNM$_STRING;
1541 if ((j+1) == nseg) {
1542 ile->buflen = strlen(c);
1543 /* in case we are truncating one that's too long */
1544 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1547 ile->buflen = LNM$C_NAMLENGTH;
1551 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1555 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1560 if (!(retsts & 1)) {
1562 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1563 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1564 set_errno(EVMSERR); break;
1565 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1566 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1567 set_errno(EINVAL); break;
1569 set_errno(EACCES); break;
1574 set_vaxc_errno(retsts);
1575 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1578 /* We reset error values on success because Perl does an hv_fetch()
1579 * before each hv_store(), and if the thing we're setting didn't
1580 * previously exist, we've got a leftover error message. (Of course,
1581 * this fails in the face of
1582 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1583 * in that the error reported in $! isn't spurious,
1584 * but it's right more often than not.)
1586 set_errno(0); set_vaxc_errno(retsts);
1590 } /* end of vmssetenv() */
1593 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1594 /* This has to be a function since there's a prototype for it in proto.h */
1596 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1599 int len = strlen(lnm);
1603 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1604 if (!strcmp(uplnm,"DEFAULT")) {
1605 if (eqv && *eqv) my_chdir(eqv);
1609 #ifndef RTL_USES_UTC
1610 if (len == 6 || len == 2) {
1613 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1615 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1616 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1620 (void) vmssetenv(lnm,eqv,NULL);
1624 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1626 * sets a user-mode logical in the process logical name table
1627 * used for redirection of sys$error
1630 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1632 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1633 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1634 unsigned long int iss, attr = LNM$M_CONFINE;
1635 unsigned char acmode = PSL$C_USER;
1636 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1638 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1639 d_name.dsc$w_length = strlen(name);
1641 lnmlst[0].buflen = strlen(eqv);
1642 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1644 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1645 if (!(iss&1)) lib$signal(iss);
1650 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1651 /* my_crypt - VMS password hashing
1652 * my_crypt() provides an interface compatible with the Unix crypt()
1653 * C library function, and uses sys$hash_password() to perform VMS
1654 * password hashing. The quadword hashed password value is returned
1655 * as a NUL-terminated 8 character string. my_crypt() does not change
1656 * the case of its string arguments; in order to match the behavior
1657 * of LOGINOUT et al., alphabetic characters in both arguments must
1658 * be upcased by the caller.
1660 * - fix me to call ACM services when available
1663 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1665 # ifndef UAI$C_PREFERRED_ALGORITHM
1666 # define UAI$C_PREFERRED_ALGORITHM 127
1668 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1669 unsigned short int salt = 0;
1670 unsigned long int sts;
1672 unsigned short int dsc$w_length;
1673 unsigned char dsc$b_type;
1674 unsigned char dsc$b_class;
1675 const char * dsc$a_pointer;
1676 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1677 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1678 struct itmlst_3 uailst[3] = {
1679 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1680 { sizeof salt, UAI$_SALT, &salt, 0},
1681 { 0, 0, NULL, NULL}};
1682 static char hash[9];
1684 usrdsc.dsc$w_length = strlen(usrname);
1685 usrdsc.dsc$a_pointer = usrname;
1686 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1688 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1692 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1697 set_vaxc_errno(sts);
1698 if (sts != RMS$_RNF) return NULL;
1701 txtdsc.dsc$w_length = strlen(textpasswd);
1702 txtdsc.dsc$a_pointer = textpasswd;
1703 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1704 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1707 return (char *) hash;
1709 } /* end of my_crypt() */
1713 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1714 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1715 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1717 /* fixup barenames that are directories for internal use.
1718 * There have been problems with the consistent handling of UNIX
1719 * style directory names when routines are presented with a name that
1720 * has no directory delimitors at all. So this routine will eventually
1723 static char * fixup_bare_dirnames(const char * name)
1725 if (decc_disable_to_vms_logname_translation) {
1732 * A little hack to get around a bug in some implemenation of remove()
1733 * that do not know how to delete a directory
1735 * Delete any file to which user has control access, regardless of whether
1736 * delete access is explicitly allowed.
1737 * Limitations: User must have write access to parent directory.
1738 * Does not block signals or ASTs; if interrupted in midstream
1739 * may leave file with an altered ACL.
1742 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1744 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1746 char *vmsname, *rspec;
1748 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1749 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1750 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1752 unsigned char myace$b_length;
1753 unsigned char myace$b_type;
1754 unsigned short int myace$w_flags;
1755 unsigned long int myace$l_access;
1756 unsigned long int myace$l_ident;
1757 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1758 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1759 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1761 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1762 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1763 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1764 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1765 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1766 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1768 /* Expand the input spec using RMS, since the CRTL remove() and
1769 * system services won't do this by themselves, so we may miss
1770 * a file "hiding" behind a logical name or search list. */
1771 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1772 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1774 if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1775 PerlMem_free(vmsname);
1779 if (decc_posix_compliant_pathnames) {
1780 /* In POSIX mode, we prefer to remove the UNIX name */
1782 remove_name = (char *)name;
1785 rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1786 if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1787 if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1788 PerlMem_free(rspec);
1789 PerlMem_free(vmsname);
1792 PerlMem_free(vmsname);
1793 remove_name = rspec;
1796 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1798 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1799 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1800 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1802 do_pathify_dirspec(name, remove_name, 0, NULL);
1803 if (!rmdir(remove_name)) {
1805 PerlMem_free(remove_name);
1806 PerlMem_free(rspec);
1807 return 0; /* Can we just get rid of it? */
1811 if (!rmdir(remove_name)) {
1812 PerlMem_free(rspec);
1813 return 0; /* Can we just get rid of it? */
1819 if (!remove(remove_name)) {
1820 PerlMem_free(rspec);
1821 return 0; /* Can we just get rid of it? */
1824 /* If not, can changing protections help? */
1825 if (vaxc$errno != RMS$_PRV) {
1826 PerlMem_free(rspec);
1830 /* No, so we get our own UIC to use as a rights identifier,
1831 * and the insert an ACE at the head of the ACL which allows us
1832 * to delete the file.
1834 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1835 fildsc.dsc$w_length = strlen(rspec);
1836 fildsc.dsc$a_pointer = rspec;
1838 newace.myace$l_ident = oldace.myace$l_ident;
1839 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1841 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1842 set_errno(ENOENT); break;
1844 set_errno(ENOTDIR); break;
1846 set_errno(ENODEV); break;
1847 case RMS$_SYN: case SS$_INVFILFOROP:
1848 set_errno(EINVAL); break;
1850 set_errno(EACCES); break;
1854 set_vaxc_errno(aclsts);
1855 PerlMem_free(rspec);
1858 /* Grab any existing ACEs with this identifier in case we fail */
1859 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1860 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1861 || fndsts == SS$_NOMOREACE ) {
1862 /* Add the new ACE . . . */
1863 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1866 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1868 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1869 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1870 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1872 do_pathify_dirspec(name, remove_name, 0, NULL);
1873 rmsts = rmdir(remove_name);
1874 PerlMem_free(remove_name);
1877 rmsts = rmdir(remove_name);
1881 rmsts = remove(remove_name);
1883 /* We blew it - dir with files in it, no write priv for
1884 * parent directory, etc. Put things back the way they were. */
1885 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1888 addlst[0].bufadr = &oldace;
1889 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1896 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1897 /* We just deleted it, so of course it's not there. Some versions of
1898 * VMS seem to return success on the unlock operation anyhow (after all
1899 * the unlock is successful), but others don't.
1901 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1902 if (aclsts & 1) aclsts = fndsts;
1903 if (!(aclsts & 1)) {
1905 set_vaxc_errno(aclsts);
1906 PerlMem_free(rspec);
1910 PerlMem_free(rspec);
1913 } /* end of kill_file() */
1917 /*{{{int do_rmdir(char *name)*/
1919 Perl_do_rmdir(pTHX_ const char *name)
1921 char dirfile[NAM$C_MAXRSS+1];
1925 if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1926 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1927 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1930 } /* end of do_rmdir */
1934 * Delete any file to which user has control access, regardless of whether
1935 * delete access is explicitly allowed.
1936 * Limitations: User must have write access to parent directory.
1937 * Does not block signals or ASTs; if interrupted in midstream
1938 * may leave file with an altered ACL.
1941 /*{{{int kill_file(char *name)*/
1943 Perl_kill_file(pTHX_ const char *name)
1945 char rspec[NAM$C_MAXRSS+1];
1947 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1948 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1949 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1951 unsigned char myace$b_length;
1952 unsigned char myace$b_type;
1953 unsigned short int myace$w_flags;
1954 unsigned long int myace$l_access;
1955 unsigned long int myace$l_ident;
1956 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1957 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1958 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1960 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1961 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1962 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1963 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1964 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1965 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1967 /* Expand the input spec using RMS, since the CRTL remove() and
1968 * system services won't do this by themselves, so we may miss
1969 * a file "hiding" behind a logical name or search list. */
1970 tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1971 if (tspec == NULL) return -1;
1972 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1973 /* If not, can changing protections help? */
1974 if (vaxc$errno != RMS$_PRV) return -1;
1976 /* No, so we get our own UIC to use as a rights identifier,
1977 * and the insert an ACE at the head of the ACL which allows us
1978 * to delete the file.
1980 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1981 fildsc.dsc$w_length = strlen(rspec);
1982 fildsc.dsc$a_pointer = rspec;
1984 newace.myace$l_ident = oldace.myace$l_ident;
1985 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1987 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1988 set_errno(ENOENT); break;
1990 set_errno(ENOTDIR); break;
1992 set_errno(ENODEV); break;
1993 case RMS$_SYN: case SS$_INVFILFOROP:
1994 set_errno(EINVAL); break;
1996 set_errno(EACCES); break;
2000 set_vaxc_errno(aclsts);
2003 /* Grab any existing ACEs with this identifier in case we fail */
2004 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2005 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2006 || fndsts == SS$_NOMOREACE ) {
2007 /* Add the new ACE . . . */
2008 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2010 if ((rmsts = remove(name))) {
2011 /* We blew it - dir with files in it, no write priv for
2012 * parent directory, etc. Put things back the way they were. */
2013 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2016 addlst[0].bufadr = &oldace;
2017 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2024 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2025 /* We just deleted it, so of course it's not there. Some versions of
2026 * VMS seem to return success on the unlock operation anyhow (after all
2027 * the unlock is successful), but others don't.
2029 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2030 if (aclsts & 1) aclsts = fndsts;
2031 if (!(aclsts & 1)) {
2033 set_vaxc_errno(aclsts);
2039 } /* end of kill_file() */
2043 /*{{{int my_mkdir(char *,Mode_t)*/
2045 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2047 STRLEN dirlen = strlen(dir);
2049 /* zero length string sometimes gives ACCVIO */
2050 if (dirlen == 0) return -1;
2052 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2053 * null file name/type. However, it's commonplace under Unix,
2054 * so we'll allow it for a gain in portability.
2056 if (dir[dirlen-1] == '/') {
2057 char *newdir = savepvn(dir,dirlen-1);
2058 int ret = mkdir(newdir,mode);
2062 else return mkdir(dir,mode);
2063 } /* end of my_mkdir */
2066 /*{{{int my_chdir(char *)*/
2068 Perl_my_chdir(pTHX_ const char *dir)
2070 STRLEN dirlen = strlen(dir);
2072 /* zero length string sometimes gives ACCVIO */
2073 if (dirlen == 0) return -1;
2076 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2077 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2078 * so that existing scripts do not need to be changed.
2081 while ((dirlen > 0) && (*dir1 == ' ')) {
2086 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2088 * null file name/type. However, it's commonplace under Unix,
2089 * so we'll allow it for a gain in portability.
2091 * - Preview- '/' will be valid soon on VMS
2093 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2094 char *newdir = savepvn(dir1,dirlen-1);
2095 int ret = chdir(newdir);
2099 else return chdir(dir1);
2100 } /* end of my_chdir */
2104 /*{{{FILE *my_tmpfile()*/
2111 if ((fp = tmpfile())) return fp;
2113 cp = PerlMem_malloc(L_tmpnam+24);
2114 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2116 if (decc_filename_unix_only == 0)
2117 strcpy(cp,"Sys$Scratch:");
2120 tmpnam(cp+strlen(cp));
2121 strcat(cp,".Perltmp");
2122 fp = fopen(cp,"w+","fop=dlt");
2129 #ifndef HOMEGROWN_POSIX_SIGNALS
2131 * The C RTL's sigaction fails to check for invalid signal numbers so we
2132 * help it out a bit. The docs are correct, but the actual routine doesn't
2133 * do what the docs say it will.
2135 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2137 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2138 struct sigaction* oact)
2140 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2141 SETERRNO(EINVAL, SS$_INVARG);
2144 return sigaction(sig, act, oact);
2149 #ifdef KILL_BY_SIGPRC
2150 #include <errnodef.h>
2152 /* We implement our own kill() using the undocumented system service
2153 sys$sigprc for one of two reasons:
2155 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2156 target process to do a sys$exit, which usually can't be handled
2157 gracefully...certainly not by Perl and the %SIG{} mechanism.
2159 2.) If the kill() in the CRTL can't be called from a signal
2160 handler without disappearing into the ether, i.e., the signal
2161 it purportedly sends is never trapped. Still true as of VMS 7.3.
2163 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2164 in the target process rather than calling sys$exit.
2166 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2167 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2168 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2169 with condition codes C$_SIG0+nsig*8, catching the exception on the
2170 target process and resignaling with appropriate arguments.
2172 But we don't have that VMS 7.0+ exception handler, so if you
2173 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2175 Also note that SIGTERM is listed in the docs as being "unimplemented",
2176 yet always seems to be signaled with a VMS condition code of 4 (and
2177 correctly handled for that code). So we hardwire it in.
2179 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2180 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2181 than signalling with an unrecognized (and unhandled by CRTL) code.
2184 #define _MY_SIG_MAX 28
2187 Perl_sig_to_vmscondition_int(int sig)
2189 static unsigned int sig_code[_MY_SIG_MAX+1] =
2192 SS$_HANGUP, /* 1 SIGHUP */
2193 SS$_CONTROLC, /* 2 SIGINT */
2194 SS$_CONTROLY, /* 3 SIGQUIT */
2195 SS$_RADRMOD, /* 4 SIGILL */
2196 SS$_BREAK, /* 5 SIGTRAP */
2197 SS$_OPCCUS, /* 6 SIGABRT */
2198 SS$_COMPAT, /* 7 SIGEMT */
2200 SS$_FLTOVF, /* 8 SIGFPE VAX */
2202 SS$_HPARITH, /* 8 SIGFPE AXP */
2204 SS$_ABORT, /* 9 SIGKILL */
2205 SS$_ACCVIO, /* 10 SIGBUS */
2206 SS$_ACCVIO, /* 11 SIGSEGV */
2207 SS$_BADPARAM, /* 12 SIGSYS */
2208 SS$_NOMBX, /* 13 SIGPIPE */
2209 SS$_ASTFLT, /* 14 SIGALRM */
2226 #if __VMS_VER >= 60200000
2227 static int initted = 0;
2230 sig_code[16] = C$_SIGUSR1;
2231 sig_code[17] = C$_SIGUSR2;
2232 #if __CRTL_VER >= 70000000
2233 sig_code[20] = C$_SIGCHLD;
2235 #if __CRTL_VER >= 70300000
2236 sig_code[28] = C$_SIGWINCH;
2241 if (sig < _SIG_MIN) return 0;
2242 if (sig > _MY_SIG_MAX) return 0;
2243 return sig_code[sig];
2247 Perl_sig_to_vmscondition(int sig)
2250 if (vms_debug_on_exception != 0)
2251 lib$signal(SS$_DEBUG);
2253 return Perl_sig_to_vmscondition_int(sig);
2258 Perl_my_kill(int pid, int sig)
2263 int sys$sigprc(unsigned int *pidadr,
2264 struct dsc$descriptor_s *prcname,
2267 /* sig 0 means validate the PID */
2268 /*------------------------------*/
2270 const unsigned long int jpicode = JPI$_PID;
2273 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2274 if ($VMS_STATUS_SUCCESS(status))
2277 case SS$_NOSUCHNODE:
2278 case SS$_UNREACHABLE:
2292 code = Perl_sig_to_vmscondition_int(sig);
2295 SETERRNO(EINVAL, SS$_BADPARAM);
2299 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2300 * signals are to be sent to multiple processes.
2301 * pid = 0 - all processes in group except ones that the system exempts
2302 * pid = -1 - all processes except ones that the system exempts
2303 * pid = -n - all processes in group (abs(n)) except ...
2304 * For now, just report as not supported.
2308 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2312 iss = sys$sigprc((unsigned int *)&pid,0,code);
2313 if (iss&1) return 0;
2317 set_errno(EPERM); break;
2319 case SS$_NOSUCHNODE:
2320 case SS$_UNREACHABLE:
2321 set_errno(ESRCH); break;
2323 set_errno(ENOMEM); break;
2328 set_vaxc_errno(iss);
2334 /* Routine to convert a VMS status code to a UNIX status code.
2335 ** More tricky than it appears because of conflicting conventions with
2338 ** VMS status codes are a bit mask, with the least significant bit set for
2341 ** Special UNIX status of EVMSERR indicates that no translation is currently
2342 ** available, and programs should check the VMS status code.
2344 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2348 #ifndef C_FACILITY_NO
2349 #define C_FACILITY_NO 0x350000
2352 #define DCL_IVVERB 0x38090
2355 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2363 /* Assume the best or the worst */
2364 if (vms_status & STS$M_SUCCESS)
2367 unix_status = EVMSERR;
2369 msg_status = vms_status & ~STS$M_CONTROL;
2371 facility = vms_status & STS$M_FAC_NO;
2372 fac_sp = vms_status & STS$M_FAC_SP;
2373 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2375 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2381 unix_status = EFAULT;
2383 case SS$_DEVOFFLINE:
2384 unix_status = EBUSY;
2387 unix_status = ENOTCONN;
2395 case SS$_INVFILFOROP:
2399 unix_status = EINVAL;
2401 case SS$_UNSUPPORTED:
2402 unix_status = ENOTSUP;
2407 unix_status = EACCES;
2409 case SS$_DEVICEFULL:
2410 unix_status = ENOSPC;
2413 unix_status = ENODEV;
2415 case SS$_NOSUCHFILE:
2416 case SS$_NOSUCHOBJECT:
2417 unix_status = ENOENT;
2419 case SS$_ABORT: /* Fatal case */
2420 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2421 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2422 unix_status = EINTR;
2425 unix_status = E2BIG;
2428 unix_status = ENOMEM;
2431 unix_status = EPERM;
2433 case SS$_NOSUCHNODE:
2434 case SS$_UNREACHABLE:
2435 unix_status = ESRCH;
2438 unix_status = ECHILD;
2441 if ((facility == 0) && (msg_no < 8)) {
2442 /* These are not real VMS status codes so assume that they are
2443 ** already UNIX status codes
2445 unix_status = msg_no;
2451 /* Translate a POSIX exit code to a UNIX exit code */
2452 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2453 unix_status = (msg_no & 0x07F8) >> 3;
2457 /* Documented traditional behavior for handling VMS child exits */
2458 /*--------------------------------------------------------------*/
2459 if (child_flag != 0) {
2461 /* Success / Informational return 0 */
2462 /*----------------------------------*/
2463 if (msg_no & STS$K_SUCCESS)
2466 /* Warning returns 1 */
2467 /*-------------------*/
2468 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2471 /* Everything else pass through the severity bits */
2472 /*------------------------------------------------*/
2473 return (msg_no & STS$M_SEVERITY);
2476 /* Normal VMS status to ERRNO mapping attempt */
2477 /*--------------------------------------------*/
2478 switch(msg_status) {
2479 /* case RMS$_EOF: */ /* End of File */
2480 case RMS$_FNF: /* File Not Found */
2481 case RMS$_DNF: /* Dir Not Found */
2482 unix_status = ENOENT;
2484 case RMS$_RNF: /* Record Not Found */
2485 unix_status = ESRCH;
2488 unix_status = ENOTDIR;
2491 unix_status = ENODEV;
2496 unix_status = EBADF;
2499 unix_status = EEXIST;
2503 case LIB$_INVSTRDES:
2505 case LIB$_NOSUCHSYM:
2506 case LIB$_INVSYMNAM:
2508 unix_status = EINVAL;
2514 unix_status = E2BIG;
2516 case RMS$_PRV: /* No privilege */
2517 case RMS$_ACC: /* ACP file access failed */
2518 case RMS$_WLK: /* Device write locked */
2519 unix_status = EACCES;
2521 /* case RMS$_NMF: */ /* No more files */
2529 /* Try to guess at what VMS error status should go with a UNIX errno
2530 * value. This is hard to do as there could be many possible VMS
2531 * error statuses that caused the errno value to be set.
2534 int Perl_unix_status_to_vms(int unix_status)
2536 int test_unix_status;
2538 /* Trivial cases first */
2539 /*---------------------*/
2540 if (unix_status == EVMSERR)
2543 /* Is vaxc$errno sane? */
2544 /*---------------------*/
2545 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2546 if (test_unix_status == unix_status)
2549 /* If way out of range, must be VMS code already */
2550 /*-----------------------------------------------*/
2551 if (unix_status > EVMSERR)
2554 /* If out of range, punt */
2555 /*-----------------------*/
2556 if (unix_status > __ERRNO_MAX)
2560 /* Ok, now we have to do it the hard way. */
2561 /*----------------------------------------*/
2562 switch(unix_status) {
2563 case 0: return SS$_NORMAL;
2564 case EPERM: return SS$_NOPRIV;
2565 case ENOENT: return SS$_NOSUCHOBJECT;
2566 case ESRCH: return SS$_UNREACHABLE;
2567 case EINTR: return SS$_ABORT;
2570 case E2BIG: return SS$_BUFFEROVF;
2572 case EBADF: return RMS$_IFI;
2573 case ECHILD: return SS$_NONEXPR;
2575 case ENOMEM: return SS$_INSFMEM;
2576 case EACCES: return SS$_FILACCERR;
2577 case EFAULT: return SS$_ACCVIO;
2579 case EBUSY: return SS$_DEVOFFLINE;
2580 case EEXIST: return RMS$_FEX;
2582 case ENODEV: return SS$_NOSUCHDEV;
2583 case ENOTDIR: return RMS$_DIR;
2585 case EINVAL: return SS$_INVARG;
2591 case ENOSPC: return SS$_DEVICEFULL;
2592 case ESPIPE: return LIB$_INVARG;
2597 case ERANGE: return LIB$_INVARG;
2598 /* case EWOULDBLOCK */
2599 /* case EINPROGRESS */
2602 /* case EDESTADDRREQ */
2604 /* case EPROTOTYPE */
2605 /* case ENOPROTOOPT */
2606 /* case EPROTONOSUPPORT */
2607 /* case ESOCKTNOSUPPORT */
2608 /* case EOPNOTSUPP */
2609 /* case EPFNOSUPPORT */
2610 /* case EAFNOSUPPORT */
2611 /* case EADDRINUSE */
2612 /* case EADDRNOTAVAIL */
2614 /* case ENETUNREACH */
2615 /* case ENETRESET */
2616 /* case ECONNABORTED */
2617 /* case ECONNRESET */
2620 case ENOTCONN: return SS$_CLEARED;
2621 /* case ESHUTDOWN */
2622 /* case ETOOMANYREFS */
2623 /* case ETIMEDOUT */
2624 /* case ECONNREFUSED */
2626 /* case ENAMETOOLONG */
2627 /* case EHOSTDOWN */
2628 /* case EHOSTUNREACH */
2629 /* case ENOTEMPTY */
2641 /* case ECANCELED */
2645 return SS$_UNSUPPORTED;
2651 /* case EABANDONED */
2653 return SS$_ABORT; /* punt */
2656 return SS$_ABORT; /* Should not get here */
2660 /* default piping mailbox size */
2661 #define PERL_BUFSIZ 512
2665 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2667 unsigned long int mbxbufsiz;
2668 static unsigned long int syssize = 0;
2669 unsigned long int dviitm = DVI$_DEVNAM;
2670 char csize[LNM$C_NAMLENGTH+1];
2674 unsigned long syiitm = SYI$_MAXBUF;
2676 * Get the SYSGEN parameter MAXBUF
2678 * If the logical 'PERL_MBX_SIZE' is defined
2679 * use the value of the logical instead of PERL_BUFSIZ, but
2680 * keep the size between 128 and MAXBUF.
2683 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2686 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2687 mbxbufsiz = atoi(csize);
2689 mbxbufsiz = PERL_BUFSIZ;
2691 if (mbxbufsiz < 128) mbxbufsiz = 128;
2692 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2694 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2696 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2697 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2699 } /* end of create_mbx() */
2702 /*{{{ my_popen and my_pclose*/
2704 typedef struct _iosb IOSB;
2705 typedef struct _iosb* pIOSB;
2706 typedef struct _pipe Pipe;
2707 typedef struct _pipe* pPipe;
2708 typedef struct pipe_details Info;
2709 typedef struct pipe_details* pInfo;
2710 typedef struct _srqp RQE;
2711 typedef struct _srqp* pRQE;
2712 typedef struct _tochildbuf CBuf;
2713 typedef struct _tochildbuf* pCBuf;
2716 unsigned short status;
2717 unsigned short count;
2718 unsigned long dvispec;
2721 #pragma member_alignment save
2722 #pragma nomember_alignment quadword
2723 struct _srqp { /* VMS self-relative queue entry */
2724 unsigned long qptr[2];
2726 #pragma member_alignment restore
2727 static RQE RQE_ZERO = {0,0};
2729 struct _tochildbuf {
2732 unsigned short size;
2740 unsigned short chan_in;
2741 unsigned short chan_out;
2743 unsigned int bufsize;
2755 #if defined(PERL_IMPLICIT_CONTEXT)
2756 void *thx; /* Either a thread or an interpreter */
2757 /* pointer, depending on how we're built */
2765 PerlIO *fp; /* file pointer to pipe mailbox */
2766 int useFILE; /* using stdio, not perlio */
2767 int pid; /* PID of subprocess */
2768 int mode; /* == 'r' if pipe open for reading */
2769 int done; /* subprocess has completed */
2770 int waiting; /* waiting for completion/closure */
2771 int closing; /* my_pclose is closing this pipe */
2772 unsigned long completion; /* termination status of subprocess */
2773 pPipe in; /* pipe in to sub */
2774 pPipe out; /* pipe out of sub */
2775 pPipe err; /* pipe of sub's sys$error */
2776 int in_done; /* true when in pipe finished */
2779 unsigned short xchan; /* channel to debug xterm */
2780 unsigned short xchan_valid; /* channel is assigned */
2783 struct exit_control_block
2785 struct exit_control_block *flink;
2786 unsigned long int (*exit_routine)();
2787 unsigned long int arg_count;
2788 unsigned long int *status_address;
2789 unsigned long int exit_status;
2792 typedef struct _closed_pipes Xpipe;
2793 typedef struct _closed_pipes* pXpipe;
2795 struct _closed_pipes {
2796 int pid; /* PID of subprocess */
2797 unsigned long completion; /* termination status of subprocess */
2799 #define NKEEPCLOSED 50
2800 static Xpipe closed_list[NKEEPCLOSED];
2801 static int closed_index = 0;
2802 static int closed_num = 0;
2804 #define RETRY_DELAY "0 ::0.20"
2805 #define MAX_RETRY 50
2807 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2808 static unsigned long mypid;
2809 static unsigned long delaytime[2];
2811 static pInfo open_pipes = NULL;
2812 static $DESCRIPTOR(nl_desc, "NL:");
2814 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2818 static unsigned long int
2819 pipe_exit_routine(pTHX)
2822 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2823 int sts, did_stuff, need_eof, j;
2826 flush any pending i/o
2832 PerlIO_flush(info->fp); /* first, flush data */
2834 fflush((FILE *)info->fp);
2840 next we try sending an EOF...ignore if doesn't work, make sure we
2848 _ckvmssts_noperl(sys$setast(0));
2849 if (info->in && !info->in->shut_on_empty) {
2850 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2855 _ckvmssts_noperl(sys$setast(1));
2859 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2861 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2866 _ckvmssts_noperl(sys$setast(0));
2867 if (info->waiting && info->done)
2869 nwait += info->waiting;
2870 _ckvmssts_noperl(sys$setast(1));
2880 _ckvmssts_noperl(sys$setast(0));
2881 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2882 sts = sys$forcex(&info->pid,0,&abort);
2883 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2886 _ckvmssts_noperl(sys$setast(1));
2890 /* again, wait for effect */
2892 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2897 _ckvmssts_noperl(sys$setast(0));
2898 if (info->waiting && info->done)
2900 nwait += info->waiting;
2901 _ckvmssts_noperl(sys$setast(1));
2910 _ckvmssts_noperl(sys$setast(0));
2911 if (!info->done) { /* We tried to be nice . . . */
2912 sts = sys$delprc(&info->pid,0);
2913 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2914 info->done = 1; /* sys$delprc is as done as we're going to get. */
2916 _ckvmssts_noperl(sys$setast(1));
2921 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2922 else if (!(sts & 1)) retsts = sts;
2927 static struct exit_control_block pipe_exitblock =
2928 {(struct exit_control_block *) 0,
2929 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2931 static void pipe_mbxtofd_ast(pPipe p);
2932 static void pipe_tochild1_ast(pPipe p);
2933 static void pipe_tochild2_ast(pPipe p);
2936 popen_completion_ast(pInfo info)
2938 pInfo i = open_pipes;
2943 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2944 closed_list[closed_index].pid = info->pid;
2945 closed_list[closed_index].completion = info->completion;
2947 if (closed_index == NKEEPCLOSED)
2952 if (i == info) break;
2955 if (!i) return; /* unlinked, probably freed too */
2960 Writing to subprocess ...
2961 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2963 chan_out may be waiting for "done" flag, or hung waiting
2964 for i/o completion to child...cancel the i/o. This will
2965 put it into "snarf mode" (done but no EOF yet) that discards
2968 Output from subprocess (stdout, stderr) needs to be flushed and
2969 shut down. We try sending an EOF, but if the mbx is full the pipe
2970 routine should still catch the "shut_on_empty" flag, telling it to
2971 use immediate-style reads so that "mbx empty" -> EOF.
2975 if (info->in && !info->in_done) { /* only for mode=w */
2976 if (info->in->shut_on_empty && info->in->need_wake) {
2977 info->in->need_wake = FALSE;
2978 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2980 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2984 if (info->out && !info->out_done) { /* were we also piping output? */
2985 info->out->shut_on_empty = TRUE;
2986 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2987 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2988 _ckvmssts_noperl(iss);
2991 if (info->err && !info->err_done) { /* we were piping stderr */
2992 info->err->shut_on_empty = TRUE;
2993 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2994 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2995 _ckvmssts_noperl(iss);
2997 _ckvmssts_noperl(sys$setef(pipe_ef));
3001 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3002 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3005 we actually differ from vmstrnenv since we use this to
3006 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3007 are pointing to the same thing
3010 static unsigned short
3011 popen_translate(pTHX_ char *logical, char *result)
3014 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3015 $DESCRIPTOR(d_log,"");
3017 unsigned short length;
3018 unsigned short code;
3020 unsigned short *retlenaddr;
3022 unsigned short l, ifi;
3024 d_log.dsc$a_pointer = logical;
3025 d_log.dsc$w_length = strlen(logical);
3027 itmlst[0].code = LNM$_STRING;
3028 itmlst[0].length = 255;
3029 itmlst[0].buffer_addr = result;
3030 itmlst[0].retlenaddr = &l;
3033 itmlst[1].length = 0;
3034 itmlst[1].buffer_addr = 0;
3035 itmlst[1].retlenaddr = 0;
3037 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3038 if (iss == SS$_NOLOGNAM) {
3042 if (!(iss&1)) lib$signal(iss);
3045 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3046 strip it off and return the ifi, if any
3049 if (result[0] == 0x1b && result[1] == 0x00) {
3050 memmove(&ifi,result+2,2);
3051 strcpy(result,result+4);
3053 return ifi; /* this is the RMS internal file id */
3056 static void pipe_infromchild_ast(pPipe p);
3059 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3060 inside an AST routine without worrying about reentrancy and which Perl
3061 memory allocator is being used.
3063 We read data and queue up the buffers, then spit them out one at a
3064 time to the output mailbox when the output mailbox is ready for one.
3067 #define INITIAL_TOCHILDQUEUE 2
3070 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3074 char mbx1[64], mbx2[64];
3075 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3076 DSC$K_CLASS_S, mbx1},
3077 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3078 DSC$K_CLASS_S, mbx2};
3079 unsigned int dviitm = DVI$_DEVBUFSIZ;
3083 _ckvmssts(lib$get_vm(&n, &p));
3085 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3086 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3087 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3090 p->shut_on_empty = FALSE;
3091 p->need_wake = FALSE;
3094 p->iosb.status = SS$_NORMAL;
3095 p->iosb2.status = SS$_NORMAL;
3101 #ifdef PERL_IMPLICIT_CONTEXT
3105 n = sizeof(CBuf) + p->bufsize;
3107 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3108 _ckvmssts(lib$get_vm(&n, &b));
3109 b->buf = (char *) b + sizeof(CBuf);
3110 _ckvmssts(lib$insqhi(b, &p->free));
3113 pipe_tochild2_ast(p);
3114 pipe_tochild1_ast(p);
3120 /* reads the MBX Perl is writing, and queues */
3123 pipe_tochild1_ast(pPipe p)
3126 int iss = p->iosb.status;
3127 int eof = (iss == SS$_ENDOFFILE);
3129 #ifdef PERL_IMPLICIT_CONTEXT
3135 p->shut_on_empty = TRUE;
3137 _ckvmssts(sys$dassgn(p->chan_in));
3143 b->size = p->iosb.count;
3144 _ckvmssts(sts = lib$insqhi(b, &p->wait));
3146 p->need_wake = FALSE;
3147 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3150 p->retry = 1; /* initial call */
3153 if (eof) { /* flush the free queue, return when done */
3154 int n = sizeof(CBuf) + p->bufsize;
3156 iss = lib$remqti(&p->free, &b);
3157 if (iss == LIB$_QUEWASEMP) return;
3159 _ckvmssts(lib$free_vm(&n, &b));
3163 iss = lib$remqti(&p->free, &b);
3164 if (iss == LIB$_QUEWASEMP) {
3165 int n = sizeof(CBuf) + p->bufsize;
3166 _ckvmssts(lib$get_vm(&n, &b));
3167 b->buf = (char *) b + sizeof(CBuf);
3173 iss = sys$qio(0,p->chan_in,
3174 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3176 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3177 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3182 /* writes queued buffers to output, waits for each to complete before
3186 pipe_tochild2_ast(pPipe p)
3189 int iss = p->iosb2.status;
3190 int n = sizeof(CBuf) + p->bufsize;
3191 int done = (p->info && p->info->done) ||
3192 iss == SS$_CANCEL || iss == SS$_ABORT;
3193 #if defined(PERL_IMPLICIT_CONTEXT)
3198 if (p->type) { /* type=1 has old buffer, dispose */
3199 if (p->shut_on_empty) {
3200 _ckvmssts(lib$free_vm(&n, &b));
3202 _ckvmssts(lib$insqhi(b, &p->free));
3207 iss = lib$remqti(&p->wait, &b);
3208 if (iss == LIB$_QUEWASEMP) {
3209 if (p->shut_on_empty) {
3211 _ckvmssts(sys$dassgn(p->chan_out));
3212 *p->pipe_done = TRUE;
3213 _ckvmssts(sys$setef(pipe_ef));
3215 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3216 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3220 p->need_wake = TRUE;
3230 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3231 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3233 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3234 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3243 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3246 char mbx1[64], mbx2[64];
3247 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3248 DSC$K_CLASS_S, mbx1},
3249 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3250 DSC$K_CLASS_S, mbx2};
3251 unsigned int dviitm = DVI$_DEVBUFSIZ;
3253 int n = sizeof(Pipe);
3254 _ckvmssts(lib$get_vm(&n, &p));
3255 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3256 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3258 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3259 n = p->bufsize * sizeof(char);
3260 _ckvmssts(lib$get_vm(&n, &p->buf));
3261 p->shut_on_empty = FALSE;
3264 p->iosb.status = SS$_NORMAL;
3265 #if defined(PERL_IMPLICIT_CONTEXT)
3268 pipe_infromchild_ast(p);
3276 pipe_infromchild_ast(pPipe p)
3278 int iss = p->iosb.status;
3279 int eof = (iss == SS$_ENDOFFILE);
3280 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3281 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3282 #if defined(PERL_IMPLICIT_CONTEXT)
3286 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3287 _ckvmssts(sys$dassgn(p->chan_out));
3292 input shutdown if EOF from self (done or shut_on_empty)
3293 output shutdown if closing flag set (my_pclose)
3294 send data/eof from child or eof from self
3295 otherwise, re-read (snarf of data from child)
3300 if (myeof && p->chan_in) { /* input shutdown */
3301 _ckvmssts(sys$dassgn(p->chan_in));
3306 if (myeof || kideof) { /* pass EOF to parent */
3307 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3308 pipe_infromchild_ast, p,
3311 } else if (eof) { /* eat EOF --- fall through to read*/
3313 } else { /* transmit data */
3314 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3315 pipe_infromchild_ast,p,
3316 p->buf, p->iosb.count, 0, 0, 0, 0));
3322 /* everything shut? flag as done */
3324 if (!p->chan_in && !p->chan_out) {
3325 *p->pipe_done = TRUE;
3326 _ckvmssts(sys$setef(pipe_ef));
3330 /* write completed (or read, if snarfing from child)
3331 if still have input active,
3332 queue read...immediate mode if shut_on_empty so we get EOF if empty
3334 check if Perl reading, generate EOFs as needed
3340 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3341 pipe_infromchild_ast,p,
3342 p->buf, p->bufsize, 0, 0, 0, 0);
3343 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3345 } else { /* send EOFs for extra reads */
3346 p->iosb.status = SS$_ENDOFFILE;
3347 p->iosb.dvispec = 0;
3348 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3350 pipe_infromchild_ast, p, 0, 0, 0, 0));
3356 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3360 unsigned long dviitm = DVI$_DEVBUFSIZ;
3362 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3363 DSC$K_CLASS_S, mbx};
3364 int n = sizeof(Pipe);
3366 /* things like terminals and mbx's don't need this filter */
3367 if (fd && fstat(fd,&s) == 0) {
3368 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3370 unsigned short dev_len;
3371 struct dsc$descriptor_s d_dev;
3373 struct item_list_3 items[3];
3375 unsigned short dvi_iosb[4];
3377 cptr = getname(fd, out, 1);
3378 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3379 d_dev.dsc$a_pointer = out;
3380 d_dev.dsc$w_length = strlen(out);
3381 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3382 d_dev.dsc$b_class = DSC$K_CLASS_S;
3385 items[0].code = DVI$_DEVCHAR;
3386 items[0].bufadr = &devchar;
3387 items[0].retadr = NULL;
3389 items[1].code = DVI$_FULLDEVNAM;
3390 items[1].bufadr = device;
3391 items[1].retadr = &dev_len;
3395 status = sys$getdviw
3396 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3398 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3399 device[dev_len] = 0;
3401 if (!(devchar & DEV$M_DIR)) {
3402 strcpy(out, device);
3408 _ckvmssts(lib$get_vm(&n, &p));
3409 p->fd_out = dup(fd);
3410 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3411 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3412 n = (p->bufsize+1) * sizeof(char);
3413 _ckvmssts(lib$get_vm(&n, &p->buf));
3414 p->shut_on_empty = FALSE;
3419 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3420 pipe_mbxtofd_ast, p,
3421 p->buf, p->bufsize, 0, 0, 0, 0));
3427 pipe_mbxtofd_ast(pPipe p)
3429 int iss = p->iosb.status;
3430 int done = p->info->done;
3432 int eof = (iss == SS$_ENDOFFILE);
3433 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3434 int err = !(iss&1) && !eof;
3435 #if defined(PERL_IMPLICIT_CONTEXT)
3439 if (done && myeof) { /* end piping */
3441 sys$dassgn(p->chan_in);
3442 *p->pipe_done = TRUE;
3443 _ckvmssts(sys$setef(pipe_ef));
3447 if (!err && !eof) { /* good data to send to file */
3448 p->buf[p->iosb.count] = '\n';
3449 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3452 if (p->retry < MAX_RETRY) {
3453 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3463 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3464 pipe_mbxtofd_ast, p,
3465 p->buf, p->bufsize, 0, 0, 0, 0);
3466 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3471 typedef struct _pipeloc PLOC;
3472 typedef struct _pipeloc* pPLOC;
3476 char dir[NAM$C_MAXRSS+1];
3478 static pPLOC head_PLOC = 0;
3481 free_pipelocs(pTHX_ void *head)
3484 pPLOC *pHead = (pPLOC *)head;
3496 store_pipelocs(pTHX)
3505 char temp[NAM$C_MAXRSS+1];
3509 free_pipelocs(aTHX_ &head_PLOC);
3511 /* the . directory from @INC comes last */
3513 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3514 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3515 p->next = head_PLOC;
3517 strcpy(p->dir,"./");
3519 /* get the directory from $^X */
3521 unixdir = PerlMem_malloc(VMS_MAXRSS);
3522 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3524 #ifdef PERL_IMPLICIT_CONTEXT
3525 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3527 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3529 strcpy(temp, PL_origargv[0]);
3530 x = strrchr(temp,']');
3532 x = strrchr(temp,'>');
3534 /* It could be a UNIX path */
3535 x = strrchr(temp,'/');
3541 /* Got a bare name, so use default directory */
3546 if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3547 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3548 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3549 p->next = head_PLOC;
3551 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3552 p->dir[NAM$C_MAXRSS] = '\0';
3556 /* reverse order of @INC entries, skip "." since entered above */
3558 #ifdef PERL_IMPLICIT_CONTEXT
3561 if (PL_incgv) av = GvAVn(PL_incgv);
3563 for (i = 0; av && i <= AvFILL(av); i++) {
3564 dirsv = *av_fetch(av,i,TRUE);
3566 if (SvROK(dirsv)) continue;
3567 dir = SvPVx(dirsv,n_a);
3568 if (strcmp(dir,".") == 0) continue;
3569 if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3572 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3573 p->next = head_PLOC;
3575 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3576 p->dir[NAM$C_MAXRSS] = '\0';
3579 /* most likely spot (ARCHLIB) put first in the list */
3582 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3583 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3584 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3585 p->next = head_PLOC;
3587 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3588 p->dir[NAM$C_MAXRSS] = '\0';
3591 PerlMem_free(unixdir);
3595 Perl_cando_by_name_int
3596 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3597 #if !defined(PERL_IMPLICIT_CONTEXT)
3598 #define cando_by_name_int Perl_cando_by_name_int
3600 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3606 static int vmspipe_file_status = 0;
3607 static char vmspipe_file[NAM$C_MAXRSS+1];
3609 /* already found? Check and use ... need read+execute permission */
3611 if (vmspipe_file_status == 1) {
3612 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3613 && cando_by_name_int
3614 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3615 return vmspipe_file;
3617 vmspipe_file_status = 0;
3620 /* scan through stored @INC, $^X */
3622 if (vmspipe_file_status == 0) {
3623 char file[NAM$C_MAXRSS+1];
3624 pPLOC p = head_PLOC;
3629 strcpy(file, p->dir);
3630 dirlen = strlen(file);
3631 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3632 file[NAM$C_MAXRSS] = '\0';
3635 exp_res = do_rmsexpand
3636 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3637 if (!exp_res) continue;
3639 if (cando_by_name_int
3640 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3641 && cando_by_name_int
3642 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3643 vmspipe_file_status = 1;
3644 return vmspipe_file;
3647 vmspipe_file_status = -1; /* failed, use tempfiles */
3654 vmspipe_tempfile(pTHX)
3656 char file[NAM$C_MAXRSS+1];
3658 static int index = 0;
3662 /* create a tempfile */
3664 /* we can't go from W, shr=get to R, shr=get without
3665 an intermediate vulnerable state, so don't bother trying...
3667 and lib$spawn doesn't shr=put, so have to close the write
3669 So... match up the creation date/time and the FID to
3670 make sure we're dealing with the same file
3675 if (!decc_filename_unix_only) {
3676 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3677 fp = fopen(file,"w");
3679 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3680 fp = fopen(file,"w");
3682 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3683 fp = fopen(file,"w");
3688 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3689 fp = fopen(file,"w");
3691 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3692 fp = fopen(file,"w");
3694 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3695 fp = fopen(file,"w");
3699 if (!fp) return 0; /* we're hosed */
3701 fprintf(fp,"$! 'f$verify(0)'\n");
3702 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3703 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3704 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3705 fprintf(fp,"$ perl_on = \"set noon\"\n");
3706 fprintf(fp,"$ perl_exit = \"exit\"\n");
3707 fprintf(fp,"$ perl_del = \"delete\"\n");
3708 fprintf(fp,"$ pif = \"if\"\n");
3709 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3710 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3711 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3712 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3713 fprintf(fp,"$! --- build command line to get max possible length\n");
3714 fprintf(fp,"$c=perl_popen_cmd0\n");
3715 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3716 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3717 fprintf(fp,"$x=perl_popen_cmd3\n");
3718 fprintf(fp,"$c=c+x\n");
3719 fprintf(fp,"$ perl_on\n");
3720 fprintf(fp,"$ 'c'\n");
3721 fprintf(fp,"$ perl_status = $STATUS\n");
3722 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3723 fprintf(fp,"$ perl_exit 'perl_status'\n");
3726 fgetname(fp, file, 1);
3727 fstat(fileno(fp), (struct stat *)&s0);
3730 if (decc_filename_unix_only)
3731 do_tounixspec(file, file, 0, NULL);
3732 fp = fopen(file,"r","shr=get");
3734 fstat(fileno(fp), (struct stat *)&s1);
3736 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3737 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3746 #ifdef USE_VMS_DECTERM
3748 static int vms_is_syscommand_xterm(void)
3750 const static struct dsc$descriptor_s syscommand_dsc =
3751 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3753 const static struct dsc$descriptor_s decwdisplay_dsc =
3754 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3756 struct item_list_3 items[2];
3757 unsigned short dvi_iosb[4];
3758 unsigned long devchar;
3759 unsigned long devclass;
3762 /* Very simple check to guess if sys$command is a decterm? */
3763 /* First see if the DECW$DISPLAY: device exists */
3765 items[0].code = DVI$_DEVCHAR;
3766 items[0].bufadr = &devchar;
3767 items[0].retadr = NULL;
3771 status = sys$getdviw
3772 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3774 if ($VMS_STATUS_SUCCESS(status)) {
3775 status = dvi_iosb[0];
3778 if (!$VMS_STATUS_SUCCESS(status)) {
3779 SETERRNO(EVMSERR, status);
3783 /* If it does, then for now assume that we are on a workstation */
3784 /* Now verify that SYS$COMMAND is a terminal */
3785 /* for creating the debugger DECTerm */
3788 items[0].code = DVI$_DEVCLASS;
3789 items[0].bufadr = &devclass;
3790 items[0].retadr = NULL;
3794 status = sys$getdviw
3795 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3797 if ($VMS_STATUS_SUCCESS(status)) {
3798 status = dvi_iosb[0];
3801 if (!$VMS_STATUS_SUCCESS(status)) {
3802 SETERRNO(EVMSERR, status);
3806 if (devclass == DC$_TERM) {
3813 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3814 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3819 char device_name[65];
3820 unsigned short device_name_len;
3821 struct dsc$descriptor_s customization_dsc;
3822 struct dsc$descriptor_s device_name_dsc;
3825 char customization[200];
3829 unsigned short p_chan;
3831 unsigned short iosb[4];
3832 struct item_list_3 items[2];
3833 const char * cust_str =
3834 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3835 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3836 DSC$K_CLASS_S, mbx1};
3838 ret_char = strstr(cmd," xterm ");
3839 if (ret_char == NULL)
3841 cptr = ret_char + 7;
3842 ret_char = strstr(cmd,"tty");
3843 if (ret_char == NULL)
3845 ret_char = strstr(cmd,"sleep");
3846 if (ret_char == NULL)
3849 /* Are we on a workstation? */
3850 /* to do: capture the rows / columns and pass their properties */
3851 ret_stat = vms_is_syscommand_xterm();
3855 /* Make the title: */
3856 ret_char = strstr(cptr,"-title");
3857 if (ret_char != NULL) {
3858 while ((*cptr != 0) && (*cptr != '\"')) {
3864 while ((*cptr != 0) && (*cptr != '\"')) {
3877 strcpy(title,"Perl Debug DECTerm");
3879 sprintf(customization, cust_str, title);
3881 customization_dsc.dsc$a_pointer = customization;
3882 customization_dsc.dsc$w_length = strlen(customization);
3883 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3884 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3886 device_name_dsc.dsc$a_pointer = device_name;
3887 device_name_dsc.dsc$w_length = sizeof device_name -1;
3888 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3889 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3891 device_name_len = 0;
3893 /* Try to create the window */
3894 status = decw$term_port
3903 if (!$VMS_STATUS_SUCCESS(status)) {
3904 SETERRNO(EVMSERR, status);
3908 device_name[device_name_len] = '\0';
3910 /* Need to set this up to look like a pipe for cleanup */
3912 status = lib$get_vm(&n, &info);
3913 if (!$VMS_STATUS_SUCCESS(status)) {
3914 SETERRNO(ENOMEM, status);
3920 info->completion = 0;
3921 info->closing = FALSE;
3928 info->in_done = TRUE;
3929 info->out_done = TRUE;
3930 info->err_done = TRUE;
3932 /* Assign a channel on this so that it will persist, and not login */
3933 /* We stash this channel in the info structure for reference. */
3934 /* The created xterm self destructs when the last channel is removed */
3935 /* and it appears that perl5db.pl (perl debugger) does this routinely */
3936 /* So leave this assigned. */
3937 device_name_dsc.dsc$w_length = device_name_len;
3938 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
3939 if (!$VMS_STATUS_SUCCESS(status)) {
3940 SETERRNO(EVMSERR, status);
3943 info->xchan_valid = 1;
3945 /* Now create a mailbox to be read by the application */
3947 create_mbx(aTHX_ &p_chan, &d_mbx1);
3949 /* write the name of the created terminal to the mailbox */
3950 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
3951 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
3953 if (!$VMS_STATUS_SUCCESS(status)) {
3954 SETERRNO(EVMSERR, status);
3958 info->fp = PerlIO_open(mbx1, mode);
3960 /* Done with this channel */
3963 /* If any errors, then clean up */
3966 _ckvmssts(lib$free_vm(&n, &info));
3976 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3978 static int handler_set_up = FALSE;
3979 unsigned long int sts, flags = CLI$M_NOWAIT;
3980 /* The use of a GLOBAL table (as was done previously) rendered
3981 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3982 * environment. Hence we've switched to LOCAL symbol table.
3984 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3986 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3987 char *in, *out, *err, mbx[512];
3989 char tfilebuf[NAM$C_MAXRSS+1];
3991 char cmd_sym_name[20];
3992 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3993 DSC$K_CLASS_S, symbol};
3994 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3996 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3997 DSC$K_CLASS_S, cmd_sym_name};
3998 struct dsc$descriptor_s *vmscmd;
3999 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4000 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4001 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4003 #ifdef USE_VMS_DECTERM
4004 /* Check here for Xterm create request. This means looking for
4005 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4006 * is possible to create an xterm.
4008 if (*in_mode == 'r') {
4011 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4012 if (xterm_fd != Nullfp)
4017 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4019 /* once-per-program initialization...
4020 note that the SETAST calls and the dual test of pipe_ef
4021 makes sure that only the FIRST thread through here does
4022 the initialization...all other threads wait until it's
4025 Yeah, uglier than a pthread call, it's got all the stuff inline
4026 rather than in a separate routine.
4030 _ckvmssts(sys$setast(0));
4032 unsigned long int pidcode = JPI$_PID;
4033 $DESCRIPTOR(d_delay, RETRY_DELAY);
4034 _ckvmssts(lib$get_ef(&pipe_ef));
4035 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4036 _ckvmssts(sys$bintim(&d_delay, delaytime));
4038 if (!handler_set_up) {
4039 _ckvmssts(sys$dclexh(&pipe_exitblock));
4040 handler_set_up = TRUE;
4042 _ckvmssts(sys$setast(1));
4045 /* see if we can find a VMSPIPE.COM */
4048 vmspipe = find_vmspipe(aTHX);
4050 strcpy(tfilebuf+1,vmspipe);
4051 } else { /* uh, oh...we're in tempfile hell */
4052 tpipe = vmspipe_tempfile(aTHX);
4053 if (!tpipe) { /* a fish popular in Boston */
4054 if (ckWARN(WARN_PIPE)) {
4055 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4059 fgetname(tpipe,tfilebuf+1,1);
4061 vmspipedsc.dsc$a_pointer = tfilebuf;
4062 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4064 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4067 case RMS$_FNF: case RMS$_DNF:
4068 set_errno(ENOENT); break;
4070 set_errno(ENOTDIR); break;
4072 set_errno(ENODEV); break;
4074 set_errno(EACCES); break;
4076 set_errno(EINVAL); break;
4077 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4078 set_errno(E2BIG); break;
4079 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4080 _ckvmssts(sts); /* fall through */
4081 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4084 set_vaxc_errno(sts);
4085 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4086 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4092 _ckvmssts(lib$get_vm(&n, &info));
4094 strcpy(mode,in_mode);
4097 info->completion = 0;
4098 info->closing = FALSE;
4105 info->in_done = TRUE;
4106 info->out_done = TRUE;
4107 info->err_done = TRUE;
4109 info->xchan_valid = 0;
4111 in = PerlMem_malloc(VMS_MAXRSS);
4112 if (in == NULL) _ckvmssts(SS$_INSFMEM);
4113 out = PerlMem_malloc(VMS_MAXRSS);
4114 if (out == NULL) _ckvmssts(SS$_INSFMEM);
4115 err = PerlMem_malloc(VMS_MAXRSS);
4116 if (err == NULL) _ckvmssts(SS$_INSFMEM);
4118 in[0] = out[0] = err[0] = '\0';
4120 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4124 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4129 if (*mode == 'r') { /* piping from subroutine */
4131 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4133 info->out->pipe_done = &info->out_done;
4134 info->out_done = FALSE;
4135 info->out->info = info;
4137 if (!info->useFILE) {
4138 info->fp = PerlIO_open(mbx, mode);
4140 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4141 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4144 if (!info->fp && info->out) {
4145 sys$cancel(info->out->chan_out);
4147 while (!info->out_done) {
4149 _ckvmssts(sys$setast(0));
4150 done = info->out_done;
4151 if (!done) _ckvmssts(sys$clref(pipe_ef));
4152 _ckvmssts(sys$setast(1));
4153 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4156 if (info->out->buf) {
4157 n = info->out->bufsize * sizeof(char);
4158 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4161 _ckvmssts(lib$free_vm(&n, &info->out));
4163 _ckvmssts(lib$free_vm(&n, &info));
4168 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4170 info->err->pipe_done = &info->err_done;
4171 info->err_done = FALSE;
4172 info->err->info = info;
4175 } else if (*mode == 'w') { /* piping to subroutine */
4177 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4179 info->out->pipe_done = &info->out_done;
4180 info->out_done = FALSE;
4181 info->out->info = info;
4184 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4186 info->err->pipe_done = &info->err_done;
4187 info->err_done = FALSE;
4188 info->err->info = info;
4191 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4192 if (!info->useFILE) {
4193 info->fp = PerlIO_open(mbx, mode);
4195 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4196 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4200 info->in->pipe_done = &info->in_done;
4201 info->in_done = FALSE;
4202 info->in->info = info;
4206 if (!info->fp && info->in) {
4208 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4209 0, 0, 0, 0, 0, 0, 0, 0));
4211 while (!info->in_done) {
4213 _ckvmssts(sys$setast(0));
4214 done = info->in_done;
4215 if (!done) _ckvmssts(sys$clref(pipe_ef));
4216 _ckvmssts(sys$setast(1));
4217 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4220 if (info->in->buf) {
4221 n = info->in->bufsize * sizeof(char);
4222 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4225 _ckvmssts(lib$free_vm(&n, &info->in));
4227 _ckvmssts(lib$free_vm(&n, &info));
4233 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4234 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4236 info->out->pipe_done = &info->out_done;
4237 info->out_done = FALSE;
4238 info->out->info = info;
4241 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4243 info->err->pipe_done = &info->err_done;
4244 info->err_done = FALSE;
4245 info->err->info = info;
4249 symbol[MAX_DCL_SYMBOL] = '\0';
4251 strncpy(symbol, in, MAX_DCL_SYMBOL);
4252 d_symbol.dsc$w_length = strlen(symbol);
4253 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4255 strncpy(symbol, err, MAX_DCL_SYMBOL);
4256 d_symbol.dsc$w_length = strlen(symbol);
4257 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4259 strncpy(symbol, out, MAX_DCL_SYMBOL);
4260 d_symbol.dsc$w_length = strlen(symbol);
4261 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4263 /* Done with the names for the pipes */
4268 p = vmscmd->dsc$a_pointer;
4269 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4270 if (*p == '$') p++; /* remove leading $ */
4271 while (*p == ' ' || *p == '\t') p++;
4273 for (j = 0; j < 4; j++) {
4274 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4275 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4277 strncpy(symbol, p, MAX_DCL_SYMBOL);
4278 d_symbol.dsc$w_length = strlen(symbol);
4279 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4281 if (strlen(p) > MAX_DCL_SYMBOL) {
4282 p += MAX_DCL_SYMBOL;
4287 _ckvmssts(sys$setast(0));
4288 info->next=open_pipes; /* prepend to list */
4290 _ckvmssts(sys$setast(1));
4291 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4292 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4293 * have SYS$COMMAND if we need it.
4295 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4296 0, &info->pid, &info->completion,
4297 0, popen_completion_ast,info,0,0,0));
4299 /* if we were using a tempfile, close it now */
4301 if (tpipe) fclose(tpipe);
4303 /* once the subprocess is spawned, it has copied the symbols and
4304 we can get rid of ours */
4306 for (j = 0; j < 4; j++) {
4307 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4308 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4309 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4311 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4312 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4313 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4314 vms_execfree(vmscmd);
4316 #ifdef PERL_IMPLICIT_CONTEXT
4319 PL_forkprocess = info->pid;
4324 _ckvmssts(sys$setast(0));
4326 if (!done) _ckvmssts(sys$clref(pipe_ef));
4327 _ckvmssts(sys$setast(1));
4328 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4330 *psts = info->completion;
4331 /* Caller thinks it is open and tries to close it. */
4332 /* This causes some problems, as it changes the error status */
4333 /* my_pclose(info->fp); */
4338 } /* end of safe_popen */
4341 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4343 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4347 TAINT_PROPER("popen");
4348 PERL_FLUSHALL_FOR_CHILD;
4349 return safe_popen(aTHX_ cmd,mode,&sts);
4354 /*{{{ I32 my_pclose(PerlIO *fp)*/
4355 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4357 pInfo info, last = NULL;
4358 unsigned long int retsts;
4362 for (info = open_pipes; info != NULL; last = info, info = info->next)
4363 if (info->fp == fp) break;
4365 if (info == NULL) { /* no such pipe open */
4366 set_errno(ECHILD); /* quoth POSIX */
4367 set_vaxc_errno(SS$_NONEXPR);
4371 /* If we were writing to a subprocess, insure that someone reading from
4372 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4373 * produce an EOF record in the mailbox.
4375 * well, at least sometimes it *does*, so we have to watch out for
4376 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4380 PerlIO_flush(info->fp); /* first, flush data */
4382 fflush((FILE *)info->fp);
4385 _ckvmssts(sys$setast(0));
4386 info->closing = TRUE;
4387 done = info->done && info->in_done && info->out_done && info->err_done;
4388 /* hanging on write to Perl's input? cancel it */
4389 if (info->mode == 'r' && info->out && !info->out_done) {
4390 if (info->out->chan_out) {
4391 _ckvmssts(sys$cancel(info->out->chan_out));
4392 if (!info->out->chan_in) { /* EOF generation, need AST */
4393 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4397 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4398 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4400 _ckvmssts(sys$setast(1));
4403 PerlIO_close(info->fp);
4405 fclose((FILE *)info->fp);
4408 we have to wait until subprocess completes, but ALSO wait until all
4409 the i/o completes...otherwise we'll be freeing the "info" structure
4410 that the i/o ASTs could still be using...
4414 _ckvmssts(sys$setast(0));
4415 done = info->done && info->in_done && info->out_done && info->err_done;
4416 if (!done) _ckvmssts(sys$clref(pipe_ef));
4417 _ckvmssts(sys$setast(1));
4418 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4420 retsts = info->completion;
4422 /* remove from list of open pipes */
4423 _ckvmssts(sys$setast(0));
4424 if (last) last->next = info->next;
4425 else open_pipes = info->next;
4426 _ckvmssts(sys$setast(1));
4428 /* free buffers and structures */
4431 if (info->in->buf) {
4432 n = info->in->bufsize * sizeof(char);
4433 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4436 _ckvmssts(lib$free_vm(&n, &info->in));
4439 if (info->out->buf) {
4440 n = info->out->bufsize * sizeof(char);
4441 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4444 _ckvmssts(lib$free_vm(&n, &info->out));
4447 if (info->err->buf) {
4448 n = info->err->bufsize * sizeof(char);
4449 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4452 _ckvmssts(lib$free_vm(&n, &info->err));
4455 _ckvmssts(lib$free_vm(&n, &info));
4459 } /* end of my_pclose() */
4461 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4462 /* Roll our own prototype because we want this regardless of whether
4463 * _VMS_WAIT is defined.
4465 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4467 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4468 created with popen(); otherwise partially emulate waitpid() unless
4469 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4470 Also check processes not considered by the CRTL waitpid().
4472 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4474 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4481 if (statusp) *statusp = 0;
4483 for (info = open_pipes; info != NULL; info = info->next)
4484 if (info->pid == pid) break;
4486 if (info != NULL) { /* we know about this child */
4487 while (!info->done) {
4488 _ckvmssts(sys$setast(0));
4490 if (!done) _ckvmssts(sys$clref(pipe_ef));
4491 _ckvmssts(sys$setast(1));
4492 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4495 if (statusp) *statusp = info->completion;
4499 /* child that already terminated? */
4501 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4502 if (closed_list[j].pid == pid) {
4503 if (statusp) *statusp = closed_list[j].completion;
4508 /* fall through if this child is not one of our own pipe children */
4510 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4512 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4513 * in 7.2 did we get a version that fills in the VMS completion
4514 * status as Perl has always tried to do.
4517 sts = __vms_waitpid( pid, statusp, flags );
4519 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4522 /* If the real waitpid tells us the child does not exist, we
4523 * fall through here to implement waiting for a child that
4524 * was created by some means other than exec() (say, spawned
4525 * from DCL) or to wait for a process that is not a subprocess
4526 * of the current process.
4529 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4532 $DESCRIPTOR(intdsc,"0 00:00:01");
4533 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4534 unsigned long int pidcode = JPI$_PID, mypid;
4535 unsigned long int interval[2];
4536 unsigned int jpi_iosb[2];
4537 struct itmlst_3 jpilist[2] = {
4538 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4543 /* Sorry folks, we don't presently implement rooting around for
4544 the first child we can find, and we definitely don't want to
4545 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4551 /* Get the owner of the child so I can warn if it's not mine. If the
4552 * process doesn't exist or I don't have the privs to look at it,
4553 * I can go home early.
4555 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4556 if (sts & 1) sts = jpi_iosb[0];
4568 set_vaxc_errno(sts);
4572 if (ckWARN(WARN_EXEC)) {
4573 /* remind folks they are asking for non-standard waitpid behavior */
4574 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4575 if (ownerpid != mypid)
4576 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4577 "waitpid: process %x is not a child of process %x",
4581 /* simply check on it once a second until it's not there anymore. */
4583 _ckvmssts(sys$bintim(&intdsc,interval));
4584 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4585 _ckvmssts(sys$schdwk(0,0,interval,0));
4586 _ckvmssts(sys$hiber());
4588 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4593 } /* end of waitpid() */
4598 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4600 my_gconvert(double val, int ndig, int trail, char *buf)
4602 static char __gcvtbuf[DBL_DIG+1];
4605 loc = buf ? buf : __gcvtbuf;
4607 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4609 sprintf(loc,"%.*g",ndig,val);
4615 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4616 return gcvt(val,ndig,loc);
4619 loc[0] = '0'; loc[1] = '\0';
4626 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4627 static int rms_free_search_context(struct FAB * fab)
4631 nam = fab->fab$l_nam;
4632 nam->nam$b_nop |= NAM$M_SYNCHK;
4633 nam->nam$l_rlf = NULL;
4635 return sys$parse(fab, NULL, NULL);
4638 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4639 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4640 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4641 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4642 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4643 #define rms_nam_esll(nam) nam.nam$b_esl
4644 #define rms_nam_esl(nam) nam.nam$b_esl
4645 #define rms_nam_name(nam) nam.nam$l_name
4646 #define rms_nam_namel(nam) nam.nam$l_name
4647 #define rms_nam_type(nam) nam.nam$l_type
4648 #define rms_nam_typel(nam) nam.nam$l_type
4649 #define rms_nam_ver(nam) nam.nam$l_ver
4650 #define rms_nam_verl(nam) nam.nam$l_ver
4651 #define rms_nam_rsll(nam) nam.nam$b_rsl
4652 #define rms_nam_rsl(nam) nam.nam$b_rsl
4653 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4654 #define rms_set_fna(fab, nam, name, size) \
4655 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4656 #define rms_get_fna(fab, nam) fab.fab$l_fna
4657 #define rms_set_dna(fab, nam, name, size) \
4658 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4659 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4660 #define rms_set_esa(fab, nam, name, size) \
4661 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4662 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4663 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4664 #define rms_set_rsa(nam, name, size) \
4665 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4666 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4667 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4668 #define rms_nam_name_type_l_size(nam) \
4669 (nam.nam$b_name + nam.nam$b_type)
4671 static int rms_free_search_context(struct FAB * fab)
4675 nam = fab->fab$l_naml;
4676 nam->naml$b_nop |= NAM$M_SYNCHK;
4677 nam->naml$l_rlf = NULL;
4678 nam->naml$l_long_defname_size = 0;
4681 return sys$parse(fab, NULL, NULL);
4684 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4685 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4686 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4687 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4688 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4689 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4690 #define rms_nam_esl(nam) nam.naml$b_esl
4691 #define rms_nam_name(nam) nam.naml$l_name
4692 #define rms_nam_namel(nam) nam.naml$l_long_name
4693 #define rms_nam_type(nam) nam.naml$l_type
4694 #define rms_nam_typel(nam) nam.naml$l_long_type
4695 #define rms_nam_ver(nam) nam.naml$l_ver
4696 #define rms_nam_verl(nam) nam.naml$l_long_ver
4697 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4698 #define rms_nam_rsl(nam) nam.naml$b_rsl
4699 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4700 #define rms_set_fna(fab, nam, name, size) \
4701 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4702 nam.naml$l_long_filename_size = size; \
4703 nam.naml$l_long_filename = name;}
4704 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4705 #define rms_set_dna(fab, nam, name, size) \
4706 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4707 nam.naml$l_long_defname_size = size; \
4708 nam.naml$l_long_defname = name; }
4709 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4710 #define rms_set_esa(fab, nam, name, size) \
4711 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4712 nam.naml$l_long_expand_alloc = size; \
4713 nam.naml$l_long_expand = name; }
4714 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4715 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4716 nam.naml$l_long_expand = l_name; \
4717 nam.naml$l_long_expand_alloc = l_size; }
4718 #define rms_set_rsa(nam, name, size) \
4719 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4720 nam.naml$l_long_result = name; \
4721 nam.naml$l_long_result_alloc = size; }
4722 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4723 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4724 nam.naml$l_long_result = l_name; \
4725 nam.naml$l_long_result_alloc = l_size; }
4726 #define rms_nam_name_type_l_size(nam) \
4727 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4731 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4732 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4733 * to expand file specification. Allows for a single default file
4734 * specification and a simple mask of options. If outbuf is non-NULL,
4735 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4736 * the resultant file specification is placed. If outbuf is NULL, the
4737 * resultant file specification is placed into a static buffer.
4738 * The third argument, if non-NULL, is taken to be a default file
4739 * specification string. The fourth argument is unused at present.
4740 * rmesexpand() returns the address of the resultant string if
4741 * successful, and NULL on error.
4743 * New functionality for previously unused opts value:
4744 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4745 * PERL_RMSEXPAND_M_LONG - Want output in long formst
4746 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4748 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4752 (pTHX_ const char *filespec,
4755 const char *defspec,
4760 static char __rmsexpand_retbuf[VMS_MAXRSS];
4761 char * vmsfspec, *tmpfspec;
4762 char * esa, *cp, *out = NULL;
4766 struct FAB myfab = cc$rms_fab;
4767 rms_setup_nam(mynam);
4769 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4772 /* temp hack until UTF8 is actually implemented */
4773 if (fs_utf8 != NULL)
4776 if (!filespec || !*filespec) {
4777 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4781 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4782 else outbuf = __rmsexpand_retbuf;
4790 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4791 isunix = is_unix_filespec(filespec);
4793 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4794 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4795 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4796 PerlMem_free(vmsfspec);
4801 filespec = vmsfspec;
4803 /* Unless we are forcing to VMS format, a UNIX input means
4804 * UNIX output, and that requires long names to be used
4806 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4807 opts |= PERL_RMSEXPAND_M_LONG;
4814 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4815 rms_bind_fab_nam(myfab, mynam);
4817 if (defspec && *defspec) {
4819 t_isunix = is_unix_filespec(defspec);
4821 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4822 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4823 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4824 PerlMem_free(tmpfspec);
4825 if (vmsfspec != NULL)
4826 PerlMem_free(vmsfspec);
4833 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4836 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4837 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4838 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4839 esal = PerlMem_malloc(VMS_MAXRSS);
4840 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4842 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4844 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4845 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4848 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4849 outbufl = PerlMem_malloc(VMS_MAXRSS);
4850 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4851 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4853 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4857 #ifdef NAM$M_NO_SHORT_UPCASE
4858 if (decc_efs_case_preserve)
4859 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4862 /* First attempt to parse as an existing file */
4863 retsts = sys$parse(&myfab,0,0);
4864 if (!(retsts & STS$K_SUCCESS)) {
4866 /* Could not find the file, try as syntax only if error is not fatal */
4867 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4868 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4869 retsts = sys$parse(&myfab,0,0);
4870 if (retsts & STS$K_SUCCESS) goto expanded;
4873 /* Still could not parse the file specification */
4874 /*----------------------------------------------*/
4875 sts = rms_free_search_context(&myfab); /* Free search context */
4876 if (out) Safefree(out);
4877 if (tmpfspec != NULL)
4878 PerlMem_free(tmpfspec);
4879 if (vmsfspec != NULL)
4880 PerlMem_free(vmsfspec);
4881 if (outbufl != NULL)
4882 PerlMem_free(outbufl);
4885 set_vaxc_errno(retsts);
4886 if (retsts == RMS$_PRV) set_errno(EACCES);
4887 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4888 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4889 else set_errno(EVMSERR);
4892 retsts = sys$search(&myfab,0,0);
4893 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4894 sts = rms_free_search_context(&myfab); /* Free search context */
4895 if (out) Safefree(out);
4896 if (tmpfspec != NULL)
4897 PerlMem_free(tmpfspec);
4898 if (vmsfspec != NULL)
4899 PerlMem_free(vmsfspec);
4900 if (outbufl != NULL)
4901 PerlMem_free(outbufl);
4904 set_vaxc_errno(retsts);
4905 if (retsts == RMS$_PRV) set_errno(EACCES);
4906 else set_errno(EVMSERR);
4910 /* If the input filespec contained any lowercase characters,
4911 * downcase the result for compatibility with Unix-minded code. */
4913 if (!decc_efs_case_preserve) {
4914 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4915 if (islower(*tbuf)) { haslower = 1; break; }
4918 /* Is a long or a short name expected */
4919 /*------------------------------------*/
4920 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4921 if (rms_nam_rsll(mynam)) {
4923 speclen = rms_nam_rsll(mynam);
4926 tbuf = esal; /* Not esa */
4927 speclen = rms_nam_esll(mynam);
4931 if (rms_nam_rsl(mynam)) {
4933 speclen = rms_nam_rsl(mynam);
4936 tbuf = esa; /* Not esal */
4937 speclen = rms_nam_esl(mynam);
4940 tbuf[speclen] = '\0';
4942 /* Trim off null fields added by $PARSE
4943 * If type > 1 char, must have been specified in original or default spec
4944 * (not true for version; $SEARCH may have added version of existing file).
4946 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4947 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4948 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4949 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4952 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4953 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4955 if (trimver || trimtype) {
4956 if (defspec && *defspec) {
4957 char *defesal = NULL;
4958 defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4959 if (defesal != NULL) {
4960 struct FAB deffab = cc$rms_fab;
4961 rms_setup_nam(defnam);
4963 rms_bind_fab_nam(deffab, defnam);
4967 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4969 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4971 rms_clear_nam_nop(defnam);
4972 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4973 #ifdef NAM$M_NO_SHORT_UPCASE
4974 if (decc_efs_case_preserve)
4975 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4977 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4979 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4982 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4985 PerlMem_free(defesal);
4989 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4990 if (*(rms_nam_verl(mynam)) != '\"')
4991 speclen = rms_nam_verl(mynam) - tbuf;
4994 if (*(rms_nam_ver(mynam)) != '\"')
4995 speclen = rms_nam_ver(mynam) - tbuf;
4999 /* If we didn't already trim version, copy down */
5000 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5001 if (speclen > rms_nam_verl(mynam) - tbuf)
5003 (rms_nam_typel(mynam),
5004 rms_nam_verl(mynam),
5005 speclen - (rms_nam_verl(mynam) - tbuf));
5006 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5009 if (speclen > rms_nam_ver(mynam) - tbuf)
5011 (rms_nam_type(mynam),
5013 speclen - (rms_nam_ver(mynam) - tbuf));
5014 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5019 /* Done with these copies of the input files */
5020 /*-------------------------------------------*/
5021 if (vmsfspec != NULL)
5022 PerlMem_free(vmsfspec);
5023 if (tmpfspec != NULL)
5024 PerlMem_free(tmpfspec);
5026 /* If we just had a directory spec on input, $PARSE "helpfully"
5027 * adds an empty name and type for us */
5028 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5029 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5030 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5031 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5032 speclen = rms_nam_namel(mynam) - tbuf;
5035 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5036 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5037 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5038 speclen = rms_nam_name(mynam) - tbuf;
5041 /* Posix format specifications must have matching quotes */
5042 if (speclen < (VMS_MAXRSS - 1)) {
5043 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5044 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5045 tbuf[speclen] = '\"';
5050 tbuf[speclen] = '\0';
5051 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5053 /* Have we been working with an expanded, but not resultant, spec? */
5054 /* Also, convert back to Unix syntax if necessary. */
5056 if (!rms_nam_rsll(mynam)) {
5058 if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
5059 if (out) Safefree(out);
5062 if (outbufl != NULL)
5063 PerlMem_free(outbufl);
5067 else strcpy(outbuf,esa);
5070 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5071 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5072 if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5073 if (out) Safefree(out);
5076 PerlMem_free(tmpfspec);
5077 if (outbufl != NULL)
5078 PerlMem_free(outbufl);
5081 strcpy(outbuf,tmpfspec);
5082 PerlMem_free(tmpfspec);
5085 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5086 sts = rms_free_search_context(&myfab); /* Free search context */
5089 if (outbufl != NULL)
5090 PerlMem_free(outbufl);
5094 /* External entry points */
5095 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5096 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5097 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5098 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5099 char *Perl_rmsexpand_utf8
5100 (pTHX_ const char *spec, char *buf, const char *def,
5101 unsigned opt, int * fs_utf8, int * dfs_utf8)
5102 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5103 char *Perl_rmsexpand_utf8_ts
5104 (pTHX_ const char *spec, char *buf, const char *def,
5105 unsigned opt, int * fs_utf8, int * dfs_utf8)
5106 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5110 ** The following routines are provided to make life easier when
5111 ** converting among VMS-style and Unix-style directory specifications.
5112 ** All will take input specifications in either VMS or Unix syntax. On
5113 ** failure, all return NULL. If successful, the routines listed below
5114 ** return a pointer to a buffer containing the appropriately
5115 ** reformatted spec (and, therefore, subsequent calls to that routine
5116 ** will clobber the result), while the routines of the same names with
5117 ** a _ts suffix appended will return a pointer to a mallocd string
5118 ** containing the appropriately reformatted spec.
5119 ** In all cases, only explicit syntax is altered; no check is made that
5120 ** the resulting string is valid or that the directory in question
5123 ** fileify_dirspec() - convert a directory spec into the name of the
5124 ** directory file (i.e. what you can stat() to see if it's a dir).
5125 ** The style (VMS or Unix) of the result is the same as the style
5126 ** of the parameter passed in.
5127 ** pathify_dirspec() - convert a directory spec into a path (i.e.
5128 ** what you prepend to a filename to indicate what directory it's in).
5129 ** The style (VMS or Unix) of the result is the same as the style
5130 ** of the parameter passed in.
5131 ** tounixpath() - convert a directory spec into a Unix-style path.
5132 ** tovmspath() - convert a directory spec into a VMS-style path.
5133 ** tounixspec() - convert any file spec into a Unix-style file spec.
5134 ** tovmsspec() - convert any file spec into a VMS-style spec.
5135 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5137 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
5138 ** Permission is given to distribute this code as part of the Perl
5139 ** standard distribution under the terms of the GNU General Public
5140 ** License or the Perl Artistic License. Copies of each may be
5141 ** found in the Perl standard distribution.
5144 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5145 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5147 static char __fileify_retbuf[VMS_MAXRSS];
5148 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5149 char *retspec, *cp1, *cp2, *lastdir;
5150 char *trndir, *vmsdir;
5151 unsigned short int trnlnm_iter_count;
5153 if (utf8_fl != NULL)
5156 if (!dir || !*dir) {
5157 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5159 dirlen = strlen(dir);
5160 while (dirlen && dir[dirlen-1] == '/') --dirlen;
5161 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5162 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5169 if (dirlen > (VMS_MAXRSS - 1)) {
5170 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5173 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5174 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5175 if (!strpbrk(dir+1,"/]>:") &&
5176 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5177 strcpy(trndir,*dir == '/' ? dir + 1: dir);
5178 trnlnm_iter_count = 0;
5179 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
5180 trnlnm_iter_count++;
5181 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5183 dirlen = strlen(trndir);
5186 strncpy(trndir,dir,dirlen);
5187 trndir[dirlen] = '\0';
5190 /* At this point we are done with *dir and use *trndir which is a
5191 * copy that can be modified. *dir must not be modified.
5194 /* If we were handed a rooted logical name or spec, treat it like a
5195 * simple directory, so that
5196 * $ Define myroot dev:[dir.]
5197 * ... do_fileify_dirspec("myroot",buf,1) ...
5198 * does something useful.
5200 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5201 trndir[--dirlen] = '\0';
5202 trndir[dirlen-1] = ']';
5204 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5205 trndir[--dirlen] = '\0';
5206 trndir[dirlen-1] = '>';
5209 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5210 /* If we've got an explicit filename, we can just shuffle the string. */
5211 if (*(cp1+1)) hasfilename = 1;
5212 /* Similarly, we can just back up a level if we've got multiple levels
5213 of explicit directories in a VMS spec which ends with directories. */
5215 for (cp2 = cp1; cp2 > trndir; cp2--) {
5217 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5218 /* fix-me, can not scan EFS file specs backward like this */
5219 *cp2 = *cp1; *cp1 = '\0';
5224 if (*cp2 == '[' || *cp2 == '<') break;
5229 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5230 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5231 cp1 = strpbrk(trndir,"]:>");
5232 if (hasfilename || !cp1) { /* Unix-style path or filename */
5233 if (trndir[0] == '.') {
5234 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5235 PerlMem_free(trndir);
5236 PerlMem_free(vmsdir);
5237 return do_fileify_dirspec("[]",buf,ts,NULL);
5239 else if (trndir[1] == '.' &&
5240 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5241 PerlMem_free(trndir);
5242 PerlMem_free(vmsdir);
5243 return do_fileify_dirspec("[-]",buf,ts,NULL);
5246 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
5247 dirlen -= 1; /* to last element */
5248 lastdir = strrchr(trndir,'/');
5250 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5251 /* If we have "/." or "/..", VMSify it and let the VMS code
5252 * below expand it, rather than repeating the code to handle
5253 * relative components of a filespec here */
5255 if (*(cp1+2) == '.') cp1++;
5256 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5258 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5259 PerlMem_free(trndir);
5260 PerlMem_free(vmsdir);
5263 if (strchr(vmsdir,'/') != NULL) {
5264 /* If do_tovmsspec() returned it, it must have VMS syntax
5265 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5266 * the time to check this here only so we avoid a recursion
5267 * loop; otherwise, gigo.
5269 PerlMem_free(trndir);
5270 PerlMem_free(vmsdir);
5271 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5274 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5275 PerlMem_free(trndir);
5276 PerlMem_free(vmsdir);
5279 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5280 PerlMem_free(trndir);
5281 PerlMem_free(vmsdir);
5285 } while ((cp1 = strstr(cp1,"/.")) != NULL);
5286 lastdir = strrchr(trndir,'/');
5288 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5290 /* Ditto for specs that end in an MFD -- let the VMS code
5291 * figure out whether it's a real device or a rooted logical. */
5293 /* This should not happen any more. Allowing the fake /000000
5294 * in a UNIX pathname causes all sorts of problems when trying
5295 * to run in UNIX emulation. So the VMS to UNIX conversions
5296 * now remove the fake /000000 directories.
5299 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5300 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5301 PerlMem_free(trndir);
5302 PerlMem_free(vmsdir);
5305 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5306 PerlMem_free(trndir);
5307 PerlMem_free(vmsdir);
5310 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5311 PerlMem_free(trndir);
5312 PerlMem_free(vmsdir);
5317 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5318 !(lastdir = cp1 = strrchr(trndir,']')) &&
5319 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5320 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
5323 /* For EFS or ODS-5 look for the last dot */
5324 if (decc_efs_charset) {
5325 cp2 = strrchr(cp1,'.');
5327 if (vms_process_case_tolerant) {
5328 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5329 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5330 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5331 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5332 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5333 (ver || *cp3)))))) {
5334 PerlMem_free(trndir);
5335 PerlMem_free(vmsdir);
5337 set_vaxc_errno(RMS$_DIR);
5342 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5343 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5344 !*(cp2+3) || *(cp2+3) != 'R' ||
5345 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5346 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5347 (ver || *cp3)))))) {
5348 PerlMem_free(trndir);
5349 PerlMem_free(vmsdir);
5351 set_vaxc_errno(RMS$_DIR);
5355 dirlen = cp2 - trndir;
5359 retlen = dirlen + 6;
5360 if (buf) retspec = buf;
5361 else if (ts) Newx(retspec,retlen+1,char);
5362 else retspec = __fileify_retbuf;
5363 memcpy(retspec,trndir,dirlen);
5364 retspec[dirlen] = '\0';
5366 /* We've picked up everything up to the directory file name.
5367 Now just add the type and version, and we're set. */
5368 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5369 strcat(retspec,".dir;1");
5371 strcat(retspec,".DIR;1");
5372 PerlMem_free(trndir);
5373 PerlMem_free(vmsdir);
5376 else { /* VMS-style directory spec */
5378 char *esa, term, *cp;
5379 unsigned long int sts, cmplen, haslower = 0;
5380 unsigned int nam_fnb;
5382 struct FAB dirfab = cc$rms_fab;
5383 rms_setup_nam(savnam);
5384 rms_setup_nam(dirnam);
5386 esa = PerlMem_malloc(VMS_MAXRSS + 1);
5387 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5388 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5389 rms_bind_fab_nam(dirfab, dirnam);
5390 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5391 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5392 #ifdef NAM$M_NO_SHORT_UPCASE
5393 if (decc_efs_case_preserve)
5394 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5397 for (cp = trndir; *cp; cp++)
5398 if (islower(*cp)) { haslower = 1; break; }
5399 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5400 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5401 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5402 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5406 PerlMem_free(trndir);
5407 PerlMem_free(vmsdir);
5409 set_vaxc_errno(dirfab.fab$l_sts);
5415 /* Does the file really exist? */
5416 if (sys$search(&dirfab)& STS$K_SUCCESS) {
5417 /* Yes; fake the fnb bits so we'll check type below */
5418 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5420 else { /* No; just work with potential name */
5421 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5424 fab_sts = dirfab.fab$l_sts;
5425 sts = rms_free_search_context(&dirfab);
5427 PerlMem_free(trndir);
5428 PerlMem_free(vmsdir);
5429 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
5434 esa[rms_nam_esll(dirnam)] = '\0';
5435 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5436 cp1 = strchr(esa,']');
5437 if (!cp1) cp1 = strchr(esa,'>');
5438 if (cp1) { /* Should always be true */
5439 rms_nam_esll(dirnam) -= cp1 - esa - 1;
5440 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5443 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5444 /* Yep; check version while we're at it, if it's there. */
5445 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5446 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5447 /* Something other than .DIR[;1]. Bzzt. */
5448 sts = rms_free_search_context(&dirfab);
5450 PerlMem_free(trndir);
5451 PerlMem_free(vmsdir);
5453 set_vaxc_errno(RMS$_DIR);
5458 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5459 /* They provided at least the name; we added the type, if necessary, */
5460 if (buf) retspec = buf; /* in sys$parse() */
5461 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5462 else retspec = __fileify_retbuf;
5463 strcpy(retspec,esa);
5464 sts = rms_free_search_context(&dirfab);
5465 PerlMem_free(trndir);
5467 PerlMem_free(vmsdir);
5470 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5471 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5473 rms_nam_esll(dirnam) -= 9;
5475 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5476 if (cp1 == NULL) { /* should never happen */
5477 sts = rms_free_search_context(&dirfab);
5478 PerlMem_free(trndir);
5480 PerlMem_free(vmsdir);
5485 retlen = strlen(esa);
5486 cp1 = strrchr(esa,'.');
5487 /* ODS-5 directory specifications can have extra "." in them. */
5488 /* Fix-me, can not scan EFS file specifications backwards */
5489 while (cp1 != NULL) {
5490 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5494 while ((cp1 > esa) && (*cp1 != '.'))
5501 if ((cp1) != NULL) {
5502 /* There's more than one directory in the path. Just roll back. */
5504 if (buf) retspec = buf;
5505 else if (ts) Newx(retspec,retlen+7,char);
5506 else retspec = __fileify_retbuf;
5507 strcpy(retspec,esa);
5510 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5511 /* Go back and expand rooted logical name */
5512 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5513 #ifdef NAM$M_NO_SHORT_UPCASE
5514 if (decc_efs_case_preserve)
5515 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5517 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5518 sts = rms_free_search_context(&dirfab);
5520 PerlMem_free(trndir);
5521 PerlMem_free(vmsdir);
5523 set_vaxc_errno(dirfab.fab$l_sts);
5526 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5527 if (buf) retspec = buf;
5528 else if (ts) Newx(retspec,retlen+16,char);
5529 else retspec = __fileify_retbuf;
5530 cp1 = strstr(esa,"][");
5531 if (!cp1) cp1 = strstr(esa,"]<");
5533 memcpy(retspec,esa,dirlen);
5534 if (!strncmp(cp1+2,"000000]",7)) {
5535 retspec[dirlen-1] = '\0';
5536 /* fix-me Not full ODS-5, just extra dots in directories for now */
5537 cp1 = retspec + dirlen - 1;
5538 while (cp1 > retspec)
5543 if (*(cp1-1) != '^')
5548 if (*cp1 == '.') *cp1 = ']';
5550 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5551 memmove(cp1+1,"000000]",7);
5555 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5556 retspec[retlen] = '\0';
5557 /* Convert last '.' to ']' */
5558 cp1 = retspec+retlen-1;
5559 while (*cp != '[') {
5562 /* Do not trip on extra dots in ODS-5 directories */
5563 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5567 if (*cp1 == '.') *cp1 = ']';
5569 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5570 memmove(cp1+1,"000000]",7);
5574 else { /* This is a top-level dir. Add the MFD to the path. */
5575 if (buf) retspec = buf;
5576 else if (ts) Newx(retspec,retlen+16,char);
5577 else retspec = __fileify_retbuf;
5580 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5581 strcpy(cp2,":[000000]");
5586 sts = rms_free_search_context(&dirfab);
5587 /* We've set up the string up through the filename. Add the
5588 type and version, and we're done. */
5589 strcat(retspec,".DIR;1");
5591 /* $PARSE may have upcased filespec, so convert output to lower
5592 * case if input contained any lowercase characters. */
5593 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5594 PerlMem_free(trndir);
5596 PerlMem_free(vmsdir);
5599 } /* end of do_fileify_dirspec() */
5601 /* External entry points */
5602 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5603 { return do_fileify_dirspec(dir,buf,0,NULL); }
5604 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5605 { return do_fileify_dirspec(dir,buf,1,NULL); }
5606 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5607 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5608 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5609 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5611 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5612 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5614 static char __pathify_retbuf[VMS_MAXRSS];
5615 unsigned long int retlen;
5616 char *retpath, *cp1, *cp2, *trndir;
5617 unsigned short int trnlnm_iter_count;
5620 if (utf8_fl != NULL)
5623 if (!dir || !*dir) {
5624 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5627 trndir = PerlMem_malloc(VMS_MAXRSS);
5628 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5629 if (*dir) strcpy(trndir,dir);
5630 else getcwd(trndir,VMS_MAXRSS - 1);
5632 trnlnm_iter_count = 0;
5633 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5634 && my_trnlnm(trndir,trndir,0)) {
5635 trnlnm_iter_count++;
5636 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5637 trnlen = strlen(trndir);
5639 /* Trap simple rooted lnms, and return lnm:[000000] */
5640 if (!strcmp(trndir+trnlen-2,".]")) {
5641 if (buf) retpath = buf;
5642 else if (ts) Newx(retpath,strlen(dir)+10,char);
5643 else retpath = __pathify_retbuf;
5644 strcpy(retpath,dir);
5645 strcat(retpath,":[000000]");
5646 PerlMem_free(trndir);
5651 /* At this point we do not work with *dir, but the copy in
5652 * *trndir that is modifiable.
5655 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5656 if (*trndir == '.' && (*(trndir+1) == '\0' ||
5657 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5658 retlen = 2 + (*(trndir+1) != '\0');
5660 if ( !(cp1 = strrchr(trndir,'/')) &&
5661 !(cp1 = strrchr(trndir,']')) &&
5662 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5663 if ((cp2 = strchr(cp1,'.')) != NULL &&
5664 (*(cp2-1) != '/' || /* Trailing '.', '..', */
5665 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
5666 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5667 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5670 /* For EFS or ODS-5 look for the last dot */
5671 if (decc_efs_charset) {
5672 cp2 = strrchr(cp1,'.');
5674 if (vms_process_case_tolerant) {
5675 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5676 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5677 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5678 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5679 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5680 (ver || *cp3)))))) {
5681 PerlMem_free(trndir);
5683 set_vaxc_errno(RMS$_DIR);
5688 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5689 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5690 !*(cp2+3) || *(cp2+3) != 'R' ||
5691 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5692 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5693 (ver || *cp3)))))) {
5694 PerlMem_free(trndir);
5696 set_vaxc_errno(RMS$_DIR);
5700 retlen = cp2 - trndir + 1;
5702 else { /* No file type present. Treat the filename as a directory. */
5703 retlen = strlen(trndir) + 1;
5706 if (buf) retpath = buf;
5707 else if (ts) Newx(retpath,retlen+1,char);
5708 else retpath = __pathify_retbuf;
5709 strncpy(retpath, trndir, retlen-1);
5710 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5711 retpath[retlen-1] = '/'; /* with '/', add it. */
5712 retpath[retlen] = '\0';
5714 else retpath[retlen-1] = '\0';
5716 else { /* VMS-style directory spec */
5718 unsigned long int sts, cmplen, haslower;
5719 struct FAB dirfab = cc$rms_fab;
5721 rms_setup_nam(savnam);
5722 rms_setup_nam(dirnam);
5724 /* If we've got an explicit filename, we can just shuffle the string. */
5725 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5726 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
5727 if ((cp2 = strchr(cp1,'.')) != NULL) {
5729 if (vms_process_case_tolerant) {
5730 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5731 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5732 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5733 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5734 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5735 (ver || *cp3)))))) {
5736 PerlMem_free(trndir);
5738 set_vaxc_errno(RMS$_DIR);
5743 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5744 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5745 !*(cp2+3) || *(cp2+3) != 'R' ||
5746 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5747 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5748 (ver || *cp3)))))) {
5749 PerlMem_free(trndir);
5751 set_vaxc_errno(RMS$_DIR);
5756 else { /* No file type, so just draw name into directory part */
5757 for (cp2 = cp1; *cp2; cp2++) ;
5760 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5762 /* We've now got a VMS 'path'; fall through */
5765 dirlen = strlen(trndir);
5766 if (trndir[dirlen-1] == ']' ||
5767 trndir[dirlen-1] == '>' ||
5768 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5769 if (buf) retpath = buf;
5770 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5771 else retpath = __pathify_retbuf;
5772 strcpy(retpath,trndir);
5773 PerlMem_free(trndir);
5776 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5777 esa = PerlMem_malloc(VMS_MAXRSS);
5778 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5779 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5780 rms_bind_fab_nam(dirfab, dirnam);
5781 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5782 #ifdef NAM$M_NO_SHORT_UPCASE
5783 if (decc_efs_case_preserve)
5784 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5787 for (cp = trndir; *cp; cp++)
5788 if (islower(*cp)) { haslower = 1; break; }
5790 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5791 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5792 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5793 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5796 PerlMem_free(trndir);
5799 set_vaxc_errno(dirfab.fab$l_sts);
5805 /* Does the file really exist? */
5806 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5807 if (dirfab.fab$l_sts != RMS$_FNF) {
5809 sts1 = rms_free_search_context(&dirfab);
5810 PerlMem_free(trndir);
5813 set_vaxc_errno(dirfab.fab$l_sts);
5816 dirnam = savnam; /* No; just work with potential name */
5819 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5820 /* Yep; check version while we're at it, if it's there. */
5821 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5822 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5824 /* Something other than .DIR[;1]. Bzzt. */
5825 sts2 = rms_free_search_context(&dirfab);
5826 PerlMem_free(trndir);
5829 set_vaxc_errno(RMS$_DIR);
5833 /* OK, the type was fine. Now pull any file name into the
5835 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5837 cp1 = strrchr(esa,'>');
5838 *(rms_nam_typel(dirnam)) = '>';
5841 *(rms_nam_typel(dirnam) + 1) = '\0';
5842 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5843 if (buf) retpath = buf;
5844 else if (ts) Newx(retpath,retlen,char);
5845 else retpath = __pathify_retbuf;
5846 strcpy(retpath,esa);
5848 sts = rms_free_search_context(&dirfab);
5849 /* $PARSE may have upcased filespec, so convert output to lower
5850 * case if input contained any lowercase characters. */
5851 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5854 PerlMem_free(trndir);
5856 } /* end of do_pathify_dirspec() */
5858 /* External entry points */
5859 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5860 { return do_pathify_dirspec(dir,buf,0,NULL); }
5861 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5862 { return do_pathify_dirspec(dir,buf,1,NULL); }
5863 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5864 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5865 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5866 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5868 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5869 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5871 static char __tounixspec_retbuf[VMS_MAXRSS];
5872 char *dirend, *rslt, *cp1, *cp3, *tmp;
5874 int devlen, dirlen, retlen = VMS_MAXRSS;
5875 int expand = 1; /* guarantee room for leading and trailing slashes */
5876 unsigned short int trnlnm_iter_count;
5878 if (utf8_fl != NULL)
5881 if (spec == NULL) return NULL;
5882 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5883 if (buf) rslt = buf;
5885 Newx(rslt, VMS_MAXRSS, char);
5887 else rslt = __tounixspec_retbuf;
5889 /* New VMS specific format needs translation
5890 * glob passes filenames with trailing '\n' and expects this preserved.
5892 if (decc_posix_compliant_pathnames) {
5893 if (strncmp(spec, "\"^UP^", 5) == 0) {
5899 tunix = PerlMem_malloc(VMS_MAXRSS);
5900 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5901 strcpy(tunix, spec);
5902 tunix_len = strlen(tunix);
5904 if (tunix[tunix_len - 1] == '\n') {
5905 tunix[tunix_len - 1] = '\"';
5906 tunix[tunix_len] = '\0';
5910 uspec = decc$translate_vms(tunix);
5911 PerlMem_free(tunix);
5912 if ((int)uspec > 0) {
5918 /* If we can not translate it, makemaker wants as-is */
5926 cmp_rslt = 0; /* Presume VMS */
5927 cp1 = strchr(spec, '/');
5931 /* Look for EFS ^/ */
5932 if (decc_efs_charset) {
5933 while (cp1 != NULL) {
5936 /* Found illegal VMS, assume UNIX */
5941 cp1 = strchr(cp1, '/');
5945 /* Look for "." and ".." */
5946 if (decc_filename_unix_report) {
5947 if (spec[0] == '.') {
5948 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5952 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5958 /* This is already UNIX or at least nothing VMS understands */
5966 dirend = strrchr(spec,']');
5967 if (dirend == NULL) dirend = strrchr(spec,'>');
5968 if (dirend == NULL) dirend = strchr(spec,':');
5969 if (dirend == NULL) {
5974 /* Special case 1 - sys$posix_root = / */
5975 #if __CRTL_VER >= 70000000
5976 if (!decc_disable_posix_root) {
5977 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5985 /* Special case 2 - Convert NLA0: to /dev/null */
5986 #if __CRTL_VER < 70000000
5987 cmp_rslt = strncmp(spec,"NLA0:", 5);
5989 cmp_rslt = strncmp(spec,"nla0:", 5);
5991 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5993 if (cmp_rslt == 0) {
5994 strcpy(rslt, "/dev/null");
5997 if (spec[6] != '\0') {
6004 /* Also handle special case "SYS$SCRATCH:" */
6005 #if __CRTL_VER < 70000000
6006 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6008 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6010 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6012 tmp = PerlMem_malloc(VMS_MAXRSS);
6013 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6014 if (cmp_rslt == 0) {
6017 islnm = my_trnlnm(tmp, "TMP", 0);
6019 strcpy(rslt, "/tmp");
6022 if (spec[12] != '\0') {
6030 if (*cp2 != '[' && *cp2 != '<') {
6033 else { /* the VMS spec begins with directories */
6035 if (*cp2 == ']' || *cp2 == '>') {
6036 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6040 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6041 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6042 if (ts) Safefree(rslt);
6046 trnlnm_iter_count = 0;
6049 while (*cp3 != ':' && *cp3) cp3++;
6051 if (strchr(cp3,']') != NULL) break;
6052 trnlnm_iter_count++;
6053 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6054 } while (vmstrnenv(tmp,tmp,0,fildev,0));
6056 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6057 retlen = devlen + dirlen;
6058 Renew(rslt,retlen+1+2*expand,char);
6064 *(cp1++) = *(cp3++);
6065 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6067 return NULL; /* No room */
6072 if ((*cp2 == '^')) {
6073 /* EFS file escape, pass the next character as is */
6074 /* Fix me: HEX encoding for UNICODE not implemented */
6077 else if ( *cp2 == '.') {
6078 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6079 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6086 for (; cp2 <= dirend; cp2++) {
6087 if ((*cp2 == '^')) {
6088 /* EFS file escape, pass the next character as is */
6089 /* Fix me: HEX encoding for UNICODE not implemented */
6095 if (*(cp2+1) == '[') cp2++;
6097 else if (*cp2 == ']' || *cp2 == '>') {
6098 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6100 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6102 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6103 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6104 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6105 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6106 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6108 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6109 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6113 else if (*cp2 == '-') {
6114 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6115 while (*cp2 == '-') {
6117 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6119 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6120 if (ts) Safefree(rslt); /* filespecs like */
6121 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
6125 else *(cp1++) = *cp2;
6127 else *(cp1++) = *cp2;
6129 while (*cp2) *(cp1++) = *(cp2++);
6132 /* This still leaves /000000/ when working with a
6133 * VMS device root or concealed root.
6139 ulen = strlen(rslt);
6141 /* Get rid of "000000/ in rooted filespecs */
6143 zeros = strstr(rslt, "/000000/");
6144 if (zeros != NULL) {
6146 mlen = ulen - (zeros - rslt) - 7;
6147 memmove(zeros, &zeros[7], mlen);
6156 } /* end of do_tounixspec() */
6158 /* External entry points */
6159 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6160 { return do_tounixspec(spec,buf,0, NULL); }
6161 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6162 { return do_tounixspec(spec,buf,1, NULL); }
6163 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6164 { return do_tounixspec(spec,buf,0, utf8_fl); }
6165 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6166 { return do_tounixspec(spec,buf,1, utf8_fl); }
6168 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6171 This procedure is used to identify if a path is based in either
6172 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6173 it returns the OpenVMS format directory for it.
6175 It is expecting specifications of only '/' or '/xxxx/'
6177 If a posix root does not exist, or 'xxxx' is not a directory
6178 in the posix root, it returns a failure.
6180 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6182 It is used only internally by posix_to_vmsspec_hardway().
6185 static int posix_root_to_vms
6186 (char *vmspath, int vmspath_len,
6187 const char *unixpath,
6188 const int * utf8_fl) {
6190 struct FAB myfab = cc$rms_fab;
6191 struct NAML mynam = cc$rms_naml;
6192 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6193 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6200 unixlen = strlen(unixpath);
6206 #if __CRTL_VER >= 80200000
6207 /* If not a posix spec already, convert it */
6208 if (decc_posix_compliant_pathnames) {
6209 if (strncmp(unixpath,"\"^UP^",5) != 0) {
6210 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6213 /* This is already a VMS specification, no conversion */
6215 strncpy(vmspath,unixpath, vmspath_len);
6224 /* Check to see if this is under the POSIX root */
6225 if (decc_disable_posix_root) {
6229 /* Skip leading / */
6230 if (unixpath[0] == '/') {
6236 strcpy(vmspath,"SYS$POSIX_ROOT:");
6238 /* If this is only the / , or blank, then... */
6239 if (unixpath[0] == '\0') {
6240 /* by definition, this is the answer */
6244 /* Need to look up a directory */
6248 /* Copy and add '^' escape characters as needed */
6251 while (unixpath[i] != 0) {
6254 j += copy_expand_unix_filename_escape
6255 (&vmspath[j], &unixpath[i], &k, utf8_fl);
6259 path_len = strlen(vmspath);
6260 if (vmspath[path_len - 1] == '/')
6262 vmspath[path_len] = ']';
6264 vmspath[path_len] = '\0';
6267 vmspath[vmspath_len] = 0;
6268 if (unixpath[unixlen - 1] == '/')
6270 esa = PerlMem_malloc(VMS_MAXRSS);
6271 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6272 myfab.fab$l_fna = vmspath;
6273 myfab.fab$b_fns = strlen(vmspath);
6274 myfab.fab$l_naml = &mynam;
6275 mynam.naml$l_esa = NULL;
6276 mynam.naml$b_ess = 0;
6277 mynam.naml$l_long_expand = esa;
6278 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6279 mynam.naml$l_rsa = NULL;
6280 mynam.naml$b_rss = 0;
6281 if (decc_efs_case_preserve)
6282 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6283 #ifdef NAML$M_OPEN_SPECIAL
6284 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6287 /* Set up the remaining naml fields */
6288 sts = sys$parse(&myfab);
6290 /* It failed! Try again as a UNIX filespec */
6296 /* get the Device ID and the FID */
6297 sts = sys$search(&myfab);
6298 /* on any failure, returned the POSIX ^UP^ filespec */
6303 specdsc.dsc$a_pointer = vmspath;
6304 specdsc.dsc$w_length = vmspath_len;
6306 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6307 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6308 sts = lib$fid_to_name
6309 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6311 /* on any failure, returned the POSIX ^UP^ filespec */
6313 /* This can happen if user does not have permission to read directories */
6314 if (strncmp(unixpath,"\"^UP^",5) != 0)
6315 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6317 strcpy(vmspath, unixpath);
6320 vmspath[specdsc.dsc$w_length] = 0;
6322 /* Are we expecting a directory? */
6323 if (dir_flag != 0) {
6329 i = specdsc.dsc$w_length - 1;
6333 /* Version must be '1' */
6334 if (vmspath[i--] != '1')
6336 /* Version delimiter is one of ".;" */
6337 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6340 if (vmspath[i--] != 'R')
6342 if (vmspath[i--] != 'I')
6344 if (vmspath[i--] != 'D')
6346 if (vmspath[i--] != '.')
6348 eptr = &vmspath[i+1];
6350 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6351 if (vmspath[i-1] != '^') {
6359 /* Get rid of 6 imaginary zero directory filename */
6360 vmspath[i+1] = '\0';
6364 if (vmspath[i] == '0')
6378 /* /dev/mumble needs to be handled special.
6379 /dev/null becomes NLA0:, And there is the potential for other stuff
6380 like /dev/tty which may need to be mapped to something.
6384 slash_dev_special_to_vms
6385 (const char * unixptr,
6395 nextslash = strchr(unixptr, '/');
6396 len = strlen(unixptr);
6397 if (nextslash != NULL)
6398 len = nextslash - unixptr;
6399 cmp = strncmp("null", unixptr, 5);
6401 if (vmspath_len >= 6) {
6402 strcpy(vmspath, "_NLA0:");
6409 /* The built in routines do not understand perl's special needs, so
6410 doing a manual conversion from UNIX to VMS
6412 If the utf8_fl is not null and points to a non-zero value, then
6413 treat 8 bit characters as UTF-8.
6415 The sequence starting with '$(' and ending with ')' will be passed
6416 through with out interpretation instead of being escaped.
6419 static int posix_to_vmsspec_hardway
6420 (char *vmspath, int vmspath_len,
6421 const char *unixpath,
6426 const char *unixptr;
6427 const char *unixend;
6429 const char *lastslash;
6430 const char *lastdot;
6436 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6437 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6439 if (utf8_fl != NULL)
6445 /* Ignore leading "/" characters */
6446 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6449 unixlen = strlen(unixptr);
6451 /* Do nothing with blank paths */
6458 /* This could have a "^UP^ on the front */
6459 if (strncmp(unixptr,"\"^UP^",5) == 0) {
6465 lastslash = strrchr(unixptr,'/');
6466 lastdot = strrchr(unixptr,'.');
6467 unixend = strrchr(unixptr,'\"');
6468 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6469 unixend = unixptr + unixlen;
6472 /* last dot is last dot or past end of string */
6473 if (lastdot == NULL)
6474 lastdot = unixptr + unixlen;
6476 /* if no directories, set last slash to beginning of string */
6477 if (lastslash == NULL) {
6478 lastslash = unixptr;
6481 /* Watch out for trailing "." after last slash, still a directory */
6482 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6483 lastslash = unixptr + unixlen;
6486 /* Watch out for traiing ".." after last slash, still a directory */
6487 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6488 lastslash = unixptr + unixlen;
6491 /* dots in directories are aways escaped */
6492 if (lastdot < lastslash)
6493 lastdot = unixptr + unixlen;
6496 /* if (unixptr < lastslash) then we are in a directory */
6503 /* Start with the UNIX path */
6504 if (*unixptr != '/') {
6505 /* relative paths */
6507 /* If allowing logical names on relative pathnames, then handle here */
6508 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6509 !decc_posix_compliant_pathnames) {
6515 /* Find the next slash */
6516 nextslash = strchr(unixptr,'/');
6518 esa = PerlMem_malloc(vmspath_len);
6519 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6521 trn = PerlMem_malloc(VMS_MAXRSS);
6522 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6524 if (nextslash != NULL) {
6526 seg_len = nextslash - unixptr;
6527 strncpy(esa, unixptr, seg_len);
6531 strcpy(esa, unixptr);
6532 seg_len = strlen(unixptr);
6534 /* trnlnm(section) */
6535 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6538 /* Now fix up the directory */
6540 /* Split up the path to find the components */
6541 sts = vms_split_path
6560 /* A logical name must be a directory or the full
6561 specification. It is only a full specification if
6562 it is the only component */
6563 if ((unixptr[seg_len] == '\0') ||
6564 (unixptr[seg_len+1] == '\0')) {
6566 /* Is a directory being required? */
6567 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6568 /* Not a logical name */
6573 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6574 /* This must be a directory */
6575 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6576 strcpy(vmsptr, esa);
6577 vmslen=strlen(vmsptr);
6578 vmsptr[vmslen] = ':';
6580 vmsptr[vmslen] = '\0';
6588 /* must be dev/directory - ignore version */
6589 if ((n_len + e_len) != 0)
6592 /* transfer the volume */
6593 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6594 strncpy(vmsptr, v_spec, v_len);
6600 /* unroot the rooted directory */
6601 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6603 r_spec[r_len - 1] = ']';
6605 /* This should not be there, but nothing is perfect */
6607 cmp = strcmp(&r_spec[1], "000000.");
6617 strncpy(vmsptr, r_spec, r_len);
6623 /* Bring over the directory. */
6625 ((d_len + vmslen) < vmspath_len)) {
6627 d_spec[d_len - 1] = ']';
6629 cmp = strcmp(&d_spec[1], "000000.");
6640 /* Remove the redundant root */
6648 strncpy(vmsptr, d_spec, d_len);
6662 if (lastslash > unixptr) {
6665 /* skip leading ./ */
6667 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6673 /* Are we still in a directory? */
6674 if (unixptr <= lastslash) {
6679 /* if not backing up, then it is relative forward. */
6680 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6681 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6689 /* Perl wants an empty directory here to tell the difference
6690 * between a DCL commmand and a filename
6699 /* Handle two special files . and .. */
6700 if (unixptr[0] == '.') {
6701 if (&unixptr[1] == unixend) {
6708 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6719 else { /* Absolute PATH handling */
6723 /* Need to find out where root is */
6725 /* In theory, this procedure should never get an absolute POSIX pathname
6726 * that can not be found on the POSIX root.
6727 * In practice, that can not be relied on, and things will show up
6728 * here that are a VMS device name or concealed logical name instead.
6729 * So to make things work, this procedure must be tolerant.
6731 esa = PerlMem_malloc(vmspath_len);
6732 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6735 nextslash = strchr(&unixptr[1],'/');
6737 if (nextslash != NULL) {
6739 seg_len = nextslash - &unixptr[1];
6740 strncpy(vmspath, unixptr, seg_len + 1);
6741 vmspath[seg_len+1] = 0;
6744 cmp = strncmp(vmspath, "dev", 4);
6746 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6747 if (sts = SS$_NORMAL)
6751 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6754 if ($VMS_STATUS_SUCCESS(sts)) {
6755 /* This is verified to be a real path */
6757 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6758 if ($VMS_STATUS_SUCCESS(sts)) {
6759 strcpy(vmspath, esa);
6760 vmslen = strlen(vmspath);
6761 vmsptr = vmspath + vmslen;
6763 if (unixptr < lastslash) {
6772 cmp = strcmp(rptr,"000000.");
6777 } /* removing 6 zeros */
6778 } /* vmslen < 7, no 6 zeros possible */
6779 } /* Not in a directory */
6780 } /* Posix root found */
6782 /* No posix root, fall back to default directory */
6783 strcpy(vmspath, "SYS$DISK:[");
6784 vmsptr = &vmspath[10];
6786 if (unixptr > lastslash) {
6795 } /* end of verified real path handling */
6800 /* Ok, we have a device or a concealed root that is not in POSIX
6801 * or we have garbage. Make the best of it.
6804 /* Posix to VMS destroyed this, so copy it again */
6805 strncpy(vmspath, &unixptr[1], seg_len);
6806 vmspath[seg_len] = 0;
6808 vmsptr = &vmsptr[vmslen];
6811 /* Now do we need to add the fake 6 zero directory to it? */
6813 if ((*lastslash == '/') && (nextslash < lastslash)) {
6814 /* No there is another directory */
6821 /* now we have foo:bar or foo:[000000]bar to decide from */
6822 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6824 if (!islnm && !decc_posix_compliant_pathnames) {
6826 cmp = strncmp("bin", vmspath, 4);
6828 /* bin => SYS$SYSTEM: */
6829 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6832 /* tmp => SYS$SCRATCH: */
6833 cmp = strncmp("tmp", vmspath, 4);
6835 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6840 trnend = islnm ? islnm - 1 : 0;
6842 /* if this was a logical name, ']' or '>' must be present */
6843 /* if not a logical name, then assume a device and hope. */
6844 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6846 /* if log name and trailing '.' then rooted - treat as device */
6847 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6849 /* Fix me, if not a logical name, a device lookup should be
6850 * done to see if the device is file structured. If the device
6851 * is not file structured, the 6 zeros should not be put on.
6853 * As it is, perl is occasionally looking for dev:[000000]tty.
6854 * which looks a little strange.
6856 * Not that easy to detect as "/dev" may be file structured with
6857 * special device files.
6860 if ((add_6zero == 0) && (*nextslash == '/') &&
6861 (&nextslash[1] == unixend)) {
6862 /* No real directory present */
6867 /* Put the device delimiter on */
6870 unixptr = nextslash;
6873 /* Start directory if needed */
6874 if (!islnm || add_6zero) {
6880 /* add fake 000000] if needed */
6893 } /* non-POSIX translation */
6895 } /* End of relative/absolute path handling */
6897 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6904 if (dir_start != 0) {
6906 /* First characters in a directory are handled special */
6907 while ((*unixptr == '/') ||
6908 ((*unixptr == '.') &&
6909 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6910 (&unixptr[1]==unixend)))) {
6915 /* Skip redundant / in specification */
6916 while ((*unixptr == '/') && (dir_start != 0)) {
6919 if (unixptr == lastslash)
6922 if (unixptr == lastslash)
6925 /* Skip redundant ./ characters */
6926 while ((*unixptr == '.') &&
6927 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6930 if (unixptr == lastslash)
6932 if (*unixptr == '/')
6935 if (unixptr == lastslash)
6938 /* Skip redundant ../ characters */
6939 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6940 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6941 /* Set the backing up flag */
6947 unixptr++; /* first . */
6948 unixptr++; /* second . */
6949 if (unixptr == lastslash)
6951 if (*unixptr == '/') /* The slash */
6954 if (unixptr == lastslash)
6957 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6958 /* Not needed when VMS is pretending to be UNIX. */
6960 /* Is this loop stuck because of too many dots? */
6961 if (loop_flag == 0) {
6962 /* Exit the loop and pass the rest through */
6967 /* Are we done with directories yet? */
6968 if (unixptr >= lastslash) {
6970 /* Watch out for trailing dots */
6979 if (*unixptr == '/')
6983 /* Have we stopped backing up? */
6988 /* dir_start continues to be = 1 */
6990 if (*unixptr == '-') {
6992 *vmsptr++ = *unixptr++;
6996 /* Now are we done with directories yet? */
6997 if (unixptr >= lastslash) {
6999 /* Watch out for trailing dots */
7015 if (unixptr >= unixend)
7018 /* Normal characters - More EFS work probably needed */
7024 /* remove multiple / */
7025 while (unixptr[1] == '/') {
7028 if (unixptr == lastslash) {
7029 /* Watch out for trailing dots */
7041 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7042 /* Not needed when VMS is pretending to be UNIX. */
7046 if (unixptr != unixend)
7051 if ((unixptr < lastdot) || (unixptr < lastslash) ||
7052 (&unixptr[1] == unixend)) {
7058 /* trailing dot ==> '^..' on VMS */
7059 if (unixptr == unixend) {
7067 *vmsptr++ = *unixptr++;
7071 if (quoted && (&unixptr[1] == unixend)) {
7075 in_cnt = copy_expand_unix_filename_escape
7076 (vmsptr, unixptr, &out_cnt, utf8_fl);
7086 in_cnt = copy_expand_unix_filename_escape
7087 (vmsptr, unixptr, &out_cnt, utf8_fl);
7094 /* Make sure directory is closed */
7095 if (unixptr == lastslash) {
7097 vmsptr2 = vmsptr - 1;
7099 if (*vmsptr2 != ']') {
7102 /* directories do not end in a dot bracket */
7103 if (*vmsptr2 == '.') {
7107 if (*vmsptr2 != '^') {
7108 vmsptr--; /* back up over the dot */
7116 /* Add a trailing dot if a file with no extension */
7117 vmsptr2 = vmsptr - 1;
7119 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7120 (*vmsptr2 != ')') && (*lastdot != '.')) {
7131 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7132 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7137 /* If a UTF8 flag is being passed, honor it */
7139 if (utf8_fl != NULL) {
7140 utf8_flag = *utf8_fl;
7145 /* If there is a possibility of UTF8, then if any UTF8 characters
7146 are present, then they must be converted to VTF-7
7148 result = strcpy(rslt, path); /* FIX-ME */
7151 result = strcpy(rslt, path);
7157 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7158 static char *mp_do_tovmsspec
7159 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7160 static char __tovmsspec_retbuf[VMS_MAXRSS];
7161 char *rslt, *dirend;
7166 unsigned long int infront = 0, hasdir = 1;
7169 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7170 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7172 if (path == NULL) return NULL;
7173 rslt_len = VMS_MAXRSS-1;
7174 if (buf) rslt = buf;
7175 else if (ts) Newx(rslt, VMS_MAXRSS, char);
7176 else rslt = __tovmsspec_retbuf;
7178 /* '.' and '..' are "[]" and "[-]" for a quick check */
7179 if (path[0] == '.') {
7180 if (path[1] == '\0') {
7182 if (utf8_flag != NULL)
7187 if (path[1] == '.' && path[2] == '\0') {
7189 if (utf8_flag != NULL)
7196 /* Posix specifications are now a native VMS format */
7197 /*--------------------------------------------------*/
7198 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7199 if (decc_posix_compliant_pathnames) {
7200 if (strncmp(path,"\"^UP^",5) == 0) {
7201 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7207 /* This is really the only way to see if this is already in VMS format */
7208 sts = vms_split_path
7223 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7224 replacement, because the above parse just took care of most of
7225 what is needed to do vmspath when the specification is already
7228 And if it is not already, it is easier to do the conversion as
7229 part of this routine than to call this routine and then work on
7233 /* If VMS punctuation was found, it is already VMS format */
7234 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7235 if (utf8_flag != NULL)
7240 /* Now, what to do with trailing "." cases where there is no
7241 extension? If this is a UNIX specification, and EFS characters
7242 are enabled, then the trailing "." should be converted to a "^.".
7243 But if this was already a VMS specification, then it should be
7246 So in the case of ambiguity, leave the specification alone.
7250 /* If there is a possibility of UTF8, then if any UTF8 characters
7251 are present, then they must be converted to VTF-7
7253 if (utf8_flag != NULL)
7259 dirend = strrchr(path,'/');
7261 if (dirend == NULL) {
7262 /* If we get here with no UNIX directory delimiters, then this is
7263 not a complete file specification, either garbage a UNIX glob
7264 specification that can not be converted to a VMS wildcard, or
7265 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7266 so apparently other programs expect this also.
7268 utf8 flag setting needs to be preserved.
7274 /* If POSIX mode active, handle the conversion */
7275 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7276 if (decc_efs_charset) {
7277 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7282 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
7283 if (!*(dirend+2)) dirend +=2;
7284 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7285 if (decc_efs_charset == 0) {
7286 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7292 lastdot = strrchr(cp2,'.');
7298 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7300 if (decc_disable_posix_root) {
7301 strcpy(rslt,"sys$disk:[000000]");
7304 strcpy(rslt,"sys$posix_root:[000000]");
7306 if (utf8_flag != NULL)
7310 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7312 trndev = PerlMem_malloc(VMS_MAXRSS);
7313 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7314 islnm = my_trnlnm(rslt,trndev,0);
7316 /* DECC special handling */
7318 if (strcmp(rslt,"bin") == 0) {
7319 strcpy(rslt,"sys$system");
7322 islnm = my_trnlnm(rslt,trndev,0);
7324 else if (strcmp(rslt,"tmp") == 0) {
7325 strcpy(rslt,"sys$scratch");
7328 islnm = my_trnlnm(rslt,trndev,0);
7330 else if (!decc_disable_posix_root) {
7331 strcpy(rslt, "sys$posix_root");
7335 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7336 islnm = my_trnlnm(rslt,trndev,0);
7338 else if (strcmp(rslt,"dev") == 0) {
7339 if (strncmp(cp2,"/null", 5) == 0) {
7340 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7341 strcpy(rslt,"NLA0");
7345 islnm = my_trnlnm(rslt,trndev,0);
7351 trnend = islnm ? strlen(trndev) - 1 : 0;
7352 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7353 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7354 /* If the first element of the path is a logical name, determine
7355 * whether it has to be translated so we can add more directories. */
7356 if (!islnm || rooted) {
7359 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7363 if (cp2 != dirend) {
7364 strcpy(rslt,trndev);
7365 cp1 = rslt + trnend;
7372 if (decc_disable_posix_root) {
7378 PerlMem_free(trndev);
7383 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7384 cp2 += 2; /* skip over "./" - it's redundant */
7385 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
7387 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7388 *(cp1++) = '-'; /* "../" --> "-" */
7391 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7392 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7393 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7394 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7397 else if ((cp2 != lastdot) || (lastdot < dirend)) {
7398 /* Escape the extra dots in EFS file specifications */
7401 if (cp2 > dirend) cp2 = dirend;
7403 else *(cp1++) = '.';
7405 for (; cp2 < dirend; cp2++) {
7407 if (*(cp2-1) == '/') continue;
7408 if (*(cp1-1) != '.') *(cp1++) = '.';
7411 else if (!infront && *cp2 == '.') {
7412 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7413 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
7414 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7415 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7416 else if (*(cp1-2) == '[') *(cp1-1) = '-';
7417 else { /* back up over previous directory name */
7419 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7420 if (*(cp1-1) == '[') {
7421 memcpy(cp1,"000000.",7);
7426 if (cp2 == dirend) break;
7428 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7429 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7430 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7431 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7433 *(cp1++) = '.'; /* Simulate trailing '/' */
7434 cp2 += 2; /* for loop will incr this to == dirend */
7436 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
7439 if (decc_efs_charset == 0)
7440 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
7442 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
7448 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
7450 if (decc_efs_charset == 0)
7457 else *(cp1++) = *cp2;
7461 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7462 if (hasdir) *(cp1++) = ']';
7463 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
7464 /* fixme for ODS5 */
7471 if (decc_efs_charset == 0)
7482 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7483 decc_readdir_dropdotnotype) {
7488 /* trailing dot ==> '^..' on VMS */
7495 *(cp1++) = *(cp2++);
7500 /* This could be a macro to be passed through */
7501 *(cp1++) = *(cp2++);
7503 const char * save_cp2;
7507 /* paranoid check */
7513 *(cp1++) = *(cp2++);
7514 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7515 *(cp1++) = *(cp2++);
7516 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7517 *(cp1++) = *(cp2++);
7520 *(cp1++) = *(cp2++);
7524 if (is_macro == 0) {
7525 /* Not really a macro - never mind */
7555 *(cp1++) = *(cp2++);
7558 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7559 * which is wrong. UNIX notation should be ".dir." unless
7560 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7561 * changing this behavior could break more things at this time.
7562 * efs character set effectively does not allow "." to be a version
7563 * delimiter as a further complication about changing this.
7565 if (decc_filename_unix_report != 0) {
7568 *(cp1++) = *(cp2++);
7571 *(cp1++) = *(cp2++);
7574 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7578 /* Fix me for "^]", but that requires making sure that you do
7579 * not back up past the start of the filename
7581 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7586 if (utf8_flag != NULL)
7590 } /* end of do_tovmsspec() */
7592 /* External entry points */
7593 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7594 { return do_tovmsspec(path,buf,0,NULL); }
7595 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7596 { return do_tovmsspec(path,buf,1,NULL); }
7597 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7598 { return do_tovmsspec(path,buf,0,utf8_fl); }
7599 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7600 { return do_tovmsspec(path,buf,1,utf8_fl); }
7602 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7603 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7604 static char __tovmspath_retbuf[VMS_MAXRSS];
7606 char *pathified, *vmsified, *cp;
7608 if (path == NULL) return NULL;
7609 pathified = PerlMem_malloc(VMS_MAXRSS);
7610 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7611 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7612 PerlMem_free(pathified);
7618 Newx(vmsified, VMS_MAXRSS, char);
7619 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7620 PerlMem_free(pathified);
7621 if (vmsified) Safefree(vmsified);
7624 PerlMem_free(pathified);
7629 vmslen = strlen(vmsified);
7630 Newx(cp,vmslen+1,char);
7631 memcpy(cp,vmsified,vmslen);
7637 strcpy(__tovmspath_retbuf,vmsified);
7639 return __tovmspath_retbuf;
7642 } /* end of do_tovmspath() */
7644 /* External entry points */
7645 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7646 { return do_tovmspath(path,buf,0, NULL); }
7647 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7648 { return do_tovmspath(path,buf,1, NULL); }
7649 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7650 { return do_tovmspath(path,buf,0,utf8_fl); }
7651 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7652 { return do_tovmspath(path,buf,1,utf8_fl); }
7655 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7656 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7657 static char __tounixpath_retbuf[VMS_MAXRSS];
7659 char *pathified, *unixified, *cp;
7661 if (path == NULL) return NULL;
7662 pathified = PerlMem_malloc(VMS_MAXRSS);
7663 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7664 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7665 PerlMem_free(pathified);
7671 Newx(unixified, VMS_MAXRSS, char);
7673 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7674 PerlMem_free(pathified);
7675 if (unixified) Safefree(unixified);
7678 PerlMem_free(pathified);
7683 unixlen = strlen(unixified);
7684 Newx(cp,unixlen+1,char);
7685 memcpy(cp,unixified,unixlen);
7687 Safefree(unixified);
7691 strcpy(__tounixpath_retbuf,unixified);
7692 Safefree(unixified);
7693 return __tounixpath_retbuf;
7696 } /* end of do_tounixpath() */
7698 /* External entry points */
7699 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7700 { return do_tounixpath(path,buf,0,NULL); }
7701 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7702 { return do_tounixpath(path,buf,1,NULL); }
7703 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7704 { return do_tounixpath(path,buf,0,utf8_fl); }
7705 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7706 { return do_tounixpath(path,buf,1,utf8_fl); }
7709 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
7711 *****************************************************************************
7713 * Copyright (C) 1989-1994 by *
7714 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
7716 * Permission is hereby granted for the reproduction of this software, *
7717 * on condition that this copyright notice is included in the reproduction, *
7718 * and that such reproduction is not for purposes of profit or material *
7721 * 27-Aug-1994 Modified for inclusion in perl5 *
7722 * by Charles Bailey bailey@newman.upenn.edu *
7723 *****************************************************************************
7727 * getredirection() is intended to aid in porting C programs
7728 * to VMS (Vax-11 C). The native VMS environment does not support
7729 * '>' and '<' I/O redirection, or command line wild card expansion,
7730 * or a command line pipe mechanism using the '|' AND background
7731 * command execution '&'. All of these capabilities are provided to any
7732 * C program which calls this procedure as the first thing in the
7734 * The piping mechanism will probably work with almost any 'filter' type
7735 * of program. With suitable modification, it may useful for other
7736 * portability problems as well.
7738 * Author: Mark Pizzolato mark@infocomm.com
7742 struct list_item *next;
7746 static void add_item(struct list_item **head,
7747 struct list_item **tail,
7751 static void mp_expand_wild_cards(pTHX_ char *item,
7752 struct list_item **head,
7753 struct list_item **tail,
7756 static int background_process(pTHX_ int argc, char **argv);
7758 static void pipe_and_fork(pTHX_ char **cmargv);
7760 /*{{{ void getredirection(int *ac, char ***av)*/
7762 mp_getredirection(pTHX_ int *ac, char ***av)
7764 * Process vms redirection arg's. Exit if any error is seen.
7765 * If getredirection() processes an argument, it is erased
7766 * from the vector. getredirection() returns a new argc and argv value.
7767 * In the event that a background command is requested (by a trailing "&"),
7768 * this routine creates a background subprocess, and simply exits the program.
7770 * Warning: do not try to simplify the code for vms. The code
7771 * presupposes that getredirection() is called before any data is
7772 * read from stdin or written to stdout.
7774 * Normal usage is as follows:
7780 * getredirection(&argc, &argv);
7784 int argc = *ac; /* Argument Count */
7785 char **argv = *av; /* Argument Vector */
7786 char *ap; /* Argument pointer */
7787 int j; /* argv[] index */
7788 int item_count = 0; /* Count of Items in List */
7789 struct list_item *list_head = 0; /* First Item in List */
7790 struct list_item *list_tail; /* Last Item in List */
7791 char *in = NULL; /* Input File Name */
7792 char *out = NULL; /* Output File Name */
7793 char *outmode = "w"; /* Mode to Open Output File */
7794 char *err = NULL; /* Error File Name */
7795 char *errmode = "w"; /* Mode to Open Error File */
7796 int cmargc = 0; /* Piped Command Arg Count */
7797 char **cmargv = NULL;/* Piped Command Arg Vector */
7800 * First handle the case where the last thing on the line ends with
7801 * a '&'. This indicates the desire for the command to be run in a
7802 * subprocess, so we satisfy that desire.
7805 if (0 == strcmp("&", ap))
7806 exit(background_process(aTHX_ --argc, argv));
7807 if (*ap && '&' == ap[strlen(ap)-1])
7809 ap[strlen(ap)-1] = '\0';
7810 exit(background_process(aTHX_ argc, argv));
7813 * Now we handle the general redirection cases that involve '>', '>>',
7814 * '<', and pipes '|'.
7816 for (j = 0; j < argc; ++j)
7818 if (0 == strcmp("<", argv[j]))
7822 fprintf(stderr,"No input file after < on command line");
7823 exit(LIB$_WRONUMARG);
7828 if ('<' == *(ap = argv[j]))
7833 if (0 == strcmp(">", ap))
7837 fprintf(stderr,"No output file after > on command line");
7838 exit(LIB$_WRONUMARG);
7857 fprintf(stderr,"No output file after > or >> on command line");
7858 exit(LIB$_WRONUMARG);
7862 if (('2' == *ap) && ('>' == ap[1]))
7879 fprintf(stderr,"No output file after 2> or 2>> on command line");
7880 exit(LIB$_WRONUMARG);
7884 if (0 == strcmp("|", argv[j]))
7888 fprintf(stderr,"No command into which to pipe on command line");
7889 exit(LIB$_WRONUMARG);
7891 cmargc = argc-(j+1);
7892 cmargv = &argv[j+1];
7896 if ('|' == *(ap = argv[j]))
7904 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7907 * Allocate and fill in the new argument vector, Some Unix's terminate
7908 * the list with an extra null pointer.
7910 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7911 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7913 for (j = 0; j < item_count; ++j, list_head = list_head->next)
7914 argv[j] = list_head->value;
7920 fprintf(stderr,"'|' and '>' may not both be specified on command line");
7921 exit(LIB$_INVARGORD);
7923 pipe_and_fork(aTHX_ cmargv);
7926 /* Check for input from a pipe (mailbox) */
7928 if (in == NULL && 1 == isapipe(0))
7930 char mbxname[L_tmpnam];
7932 long int dvi_item = DVI$_DEVBUFSIZ;
7933 $DESCRIPTOR(mbxnam, "");
7934 $DESCRIPTOR(mbxdevnam, "");
7936 /* Input from a pipe, reopen it in binary mode to disable */
7937 /* carriage control processing. */
7939 fgetname(stdin, mbxname);
7940 mbxnam.dsc$a_pointer = mbxname;
7941 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7942 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7943 mbxdevnam.dsc$a_pointer = mbxname;
7944 mbxdevnam.dsc$w_length = sizeof(mbxname);
7945 dvi_item = DVI$_DEVNAM;
7946 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7947 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7950 freopen(mbxname, "rb", stdin);
7953 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7957 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7959 fprintf(stderr,"Can't open input file %s as stdin",in);
7962 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7964 fprintf(stderr,"Can't open output file %s as stdout",out);
7967 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7970 if (strcmp(err,"&1") == 0) {
7971 dup2(fileno(stdout), fileno(stderr));
7972 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7975 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7977 fprintf(stderr,"Can't open error file %s as stderr",err);
7981 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7985 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7988 #ifdef ARGPROC_DEBUG
7989 PerlIO_printf(Perl_debug_log, "Arglist:\n");
7990 for (j = 0; j < *ac; ++j)
7991 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7993 /* Clear errors we may have hit expanding wildcards, so they don't
7994 show up in Perl's $! later */
7995 set_errno(0); set_vaxc_errno(1);
7996 } /* end of getredirection() */
7999 static void add_item(struct list_item **head,
8000 struct list_item **tail,
8006 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8007 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8011 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8012 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8013 *tail = (*tail)->next;
8015 (*tail)->value = value;
8019 static void mp_expand_wild_cards(pTHX_ char *item,
8020 struct list_item **head,
8021 struct list_item **tail,
8025 unsigned long int context = 0;
8033 $DESCRIPTOR(filespec, "");
8034 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8035 $DESCRIPTOR(resultspec, "");
8036 unsigned long int lff_flags = 0;
8040 #ifdef VMS_LONGNAME_SUPPORT
8041 lff_flags = LIB$M_FIL_LONG_NAMES;
8044 for (cp = item; *cp; cp++) {
8045 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8046 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8048 if (!*cp || isspace(*cp))
8050 add_item(head, tail, item, count);
8055 /* "double quoted" wild card expressions pass as is */
8056 /* From DCL that means using e.g.: */
8057 /* perl program """perl.*""" */
8058 item_len = strlen(item);
8059 if ( '"' == *item && '"' == item[item_len-1] )
8062 item[item_len-2] = '\0';
8063 add_item(head, tail, item, count);
8067 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8068 resultspec.dsc$b_class = DSC$K_CLASS_D;
8069 resultspec.dsc$a_pointer = NULL;
8070 vmsspec = PerlMem_malloc(VMS_MAXRSS);
8071 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8072 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8073 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8074 if (!isunix || !filespec.dsc$a_pointer)
8075 filespec.dsc$a_pointer = item;
8076 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8078 * Only return version specs, if the caller specified a version
8080 had_version = strchr(item, ';');
8082 * Only return device and directory specs, if the caller specifed either.
8084 had_device = strchr(item, ':');
8085 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8087 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8088 (&filespec, &resultspec, &context,
8089 &defaultspec, 0, &rms_sts, &lff_flags)))
8094 string = PerlMem_malloc(resultspec.dsc$w_length+1);
8095 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8096 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8097 string[resultspec.dsc$w_length] = '\0';
8098 if (NULL == had_version)
8099 *(strrchr(string, ';')) = '\0';
8100 if ((!had_directory) && (had_device == NULL))
8102 if (NULL == (devdir = strrchr(string, ']')))
8103 devdir = strrchr(string, '>');
8104 strcpy(string, devdir + 1);
8107 * Be consistent with what the C RTL has already done to the rest of
8108 * the argv items and lowercase all of these names.
8110 if (!decc_efs_case_preserve) {
8111 for (c = string; *c; ++c)
8115 if (isunix) trim_unixpath(string,item,1);
8116 add_item(head, tail, string, count);
8119 PerlMem_free(vmsspec);
8120 if (sts != RMS$_NMF)
8122 set_vaxc_errno(sts);
8125 case RMS$_FNF: case RMS$_DNF:
8126 set_errno(ENOENT); break;
8128 set_errno(ENOTDIR); break;
8130 set_errno(ENODEV); break;
8131 case RMS$_FNM: case RMS$_SYN:
8132 set_errno(EINVAL); break;
8134 set_errno(EACCES); break;
8136 _ckvmssts_noperl(sts);
8140 add_item(head, tail, item, count);
8141 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8142 _ckvmssts_noperl(lib$find_file_end(&context));
8145 static int child_st[2];/* Event Flag set when child process completes */
8147 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
8149 static unsigned long int exit_handler(int *status)
8153 if (0 == child_st[0])
8155 #ifdef ARGPROC_DEBUG
8156 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8158 fflush(stdout); /* Have to flush pipe for binary data to */
8159 /* terminate properly -- <tp@mccall.com> */
8160 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8161 sys$dassgn(child_chan);
8163 sys$synch(0, child_st);
8168 static void sig_child(int chan)
8170 #ifdef ARGPROC_DEBUG
8171 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8173 if (child_st[0] == 0)
8177 static struct exit_control_block exit_block =
8182 &exit_block.exit_status,
8187 pipe_and_fork(pTHX_ char **cmargv)
8190 struct dsc$descriptor_s *vmscmd;
8191 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8192 int sts, j, l, ismcr, quote, tquote = 0;
8194 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
8195 vms_execfree(vmscmd);
8200 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
8201 && toupper(*(q+2)) == 'R' && !*(q+3);
8203 while (q && l < MAX_DCL_LINE_LENGTH) {
8205 if (j > 0 && quote) {
8211 if (ismcr && j > 1) quote = 1;
8212 tquote = (strchr(q,' ')) != NULL || *q == '\0';
8215 if (quote || tquote) {
8221 if ((quote||tquote) && *q == '"') {
8231 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8233 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8237 static int background_process(pTHX_ int argc, char **argv)
8239 char command[MAX_DCL_SYMBOL + 1] = "$";
8240 $DESCRIPTOR(value, "");
8241 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8242 static $DESCRIPTOR(null, "NLA0:");
8243 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8245 $DESCRIPTOR(pidstr, "");
8247 unsigned long int flags = 17, one = 1, retsts;
8250 strcat(command, argv[0]);
8251 len = strlen(command);
8252 while (--argc && (len < MAX_DCL_SYMBOL))
8254 strcat(command, " \"");
8255 strcat(command, *(++argv));
8256 strcat(command, "\"");
8257 len = strlen(command);
8259 value.dsc$a_pointer = command;
8260 value.dsc$w_length = strlen(value.dsc$a_pointer);
8261 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8262 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8263 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8264 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8267 _ckvmssts_noperl(retsts);
8269 #ifdef ARGPROC_DEBUG
8270 PerlIO_printf(Perl_debug_log, "%s\n", command);
8272 sprintf(pidstring, "%08X", pid);
8273 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8274 pidstr.dsc$a_pointer = pidstring;
8275 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8276 lib$set_symbol(&pidsymbol, &pidstr);
8280 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8283 /* OS-specific initialization at image activation (not thread startup) */
8284 /* Older VAXC header files lack these constants */
8285 #ifndef JPI$_RIGHTS_SIZE
8286 # define JPI$_RIGHTS_SIZE 817
8288 #ifndef KGB$M_SUBSYSTEM
8289 # define KGB$M_SUBSYSTEM 0x8
8292 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8294 /*{{{void vms_image_init(int *, char ***)*/
8296 vms_image_init(int *argcp, char ***argvp)
8298 char eqv[LNM$C_NAMLENGTH+1] = "";
8299 unsigned int len, tabct = 8, tabidx = 0;
8300 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8301 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8302 unsigned short int dummy, rlen;
8303 struct dsc$descriptor_s **tabvec;
8304 #if defined(PERL_IMPLICIT_CONTEXT)
8307 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8308 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8309 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8312 #ifdef KILL_BY_SIGPRC
8313 Perl_csighandler_init();
8316 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8317 _ckvmssts_noperl(iosb[0]);
8318 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8319 if (iprv[i]) { /* Running image installed with privs? */
8320 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
8325 /* Rights identifiers might trigger tainting as well. */
8326 if (!will_taint && (rlen || rsz)) {
8327 while (rlen < rsz) {
8328 /* We didn't get all the identifiers on the first pass. Allocate a
8329 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8330 * were needed to hold all identifiers at time of last call; we'll
8331 * allocate that many unsigned long ints), and go back and get 'em.
8332 * If it gave us less than it wanted to despite ample buffer space,
8333 * something's broken. Is your system missing a system identifier?
8335 if (rsz <= jpilist[1].buflen) {
8336 /* Perl_croak accvios when used this early in startup. */
8337 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8338 rsz, (unsigned long) jpilist[1].buflen,
8339 "Check your rights database for corruption.\n");
8342 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8343 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8344 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8345 jpilist[1].buflen = rsz * sizeof(unsigned long int);
8346 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8347 _ckvmssts_noperl(iosb[0]);
8349 mask = jpilist[1].bufadr;
8350 /* Check attribute flags for each identifier (2nd longword); protected
8351 * subsystem identifiers trigger tainting.
8353 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8354 if (mask[i] & KGB$M_SUBSYSTEM) {
8359 if (mask != rlst) PerlMem_free(mask);
8362 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8363 * logical, some versions of the CRTL will add a phanthom /000000/
8364 * directory. This needs to be removed.
8366 if (decc_filename_unix_report) {
8369 ulen = strlen(argvp[0][0]);
8371 zeros = strstr(argvp[0][0], "/000000/");
8372 if (zeros != NULL) {
8374 mlen = ulen - (zeros - argvp[0][0]) - 7;
8375 memmove(zeros, &zeros[7], mlen);
8377 argvp[0][0][ulen] = '\0';
8380 /* It also may have a trailing dot that needs to be removed otherwise
8381 * it will be converted to VMS mode incorrectly.
8384 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8385 argvp[0][0][ulen] = '\0';
8388 /* We need to use this hack to tell Perl it should run with tainting,
8389 * since its tainting flag may be part of the PL_curinterp struct, which
8390 * hasn't been allocated when vms_image_init() is called.
8393 char **newargv, **oldargv;
8395 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8396 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8397 newargv[0] = oldargv[0];
8398 newargv[1] = PerlMem_malloc(3 * sizeof(char));
8399 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8400 strcpy(newargv[1], "-T");
8401 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8403 newargv[*argcp] = NULL;
8404 /* We orphan the old argv, since we don't know where it's come from,
8405 * so we don't know how to free it.
8409 else { /* Did user explicitly request tainting? */
8411 char *cp, **av = *argvp;
8412 for (i = 1; i < *argcp; i++) {
8413 if (*av[i] != '-') break;
8414 for (cp = av[i]+1; *cp; cp++) {
8415 if (*cp == 'T') { will_taint = 1; break; }
8416 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8417 strchr("DFIiMmx",*cp)) break;
8419 if (will_taint) break;
8424 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8427 tabvec = (struct dsc$descriptor_s **)
8428 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8429 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8431 else if (tabidx >= tabct) {
8433 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8434 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8436 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8437 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8438 tabvec[tabidx]->dsc$w_length = 0;
8439 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
8440 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
8441 tabvec[tabidx]->dsc$a_pointer = NULL;
8442 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8444 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8446 getredirection(argcp,argvp);
8447 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8449 # include <reentrancy.h>
8450 decc$set_reentrancy(C$C_MULTITHREAD);
8459 * Trim Unix-style prefix off filespec, so it looks like what a shell
8460 * glob expansion would return (i.e. from specified prefix on, not
8461 * full path). Note that returned filespec is Unix-style, regardless
8462 * of whether input filespec was VMS-style or Unix-style.
8464 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8465 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
8466 * vector of options; at present, only bit 0 is used, and if set tells
8467 * trim unixpath to try the current default directory as a prefix when
8468 * presented with a possibly ambiguous ... wildcard.
8470 * Returns !=0 on success, with trimmed filespec replacing contents of
8471 * fspec, and 0 on failure, with contents of fpsec unchanged.
8473 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8475 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8477 char *unixified, *unixwild,
8478 *template, *base, *end, *cp1, *cp2;
8479 register int tmplen, reslen = 0, dirs = 0;
8481 unixwild = PerlMem_malloc(VMS_MAXRSS);
8482 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8483 if (!wildspec || !fspec) return 0;
8484 template = unixwild;
8485 if (strpbrk(wildspec,"]>:") != NULL) {
8486 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8487 PerlMem_free(unixwild);
8492 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8493 unixwild[VMS_MAXRSS-1] = 0;
8495 unixified = PerlMem_malloc(VMS_MAXRSS);
8496 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8497 if (strpbrk(fspec,"]>:") != NULL) {
8498 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8499 PerlMem_free(unixwild);
8500 PerlMem_free(unixified);
8503 else base = unixified;
8504 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8505 * check to see that final result fits into (isn't longer than) fspec */
8506 reslen = strlen(fspec);
8510 /* No prefix or absolute path on wildcard, so nothing to remove */
8511 if (!*template || *template == '/') {
8512 PerlMem_free(unixwild);
8513 if (base == fspec) {
8514 PerlMem_free(unixified);
8517 tmplen = strlen(unixified);
8518 if (tmplen > reslen) {
8519 PerlMem_free(unixified);
8520 return 0; /* not enough space */
8522 /* Copy unixified resultant, including trailing NUL */
8523 memmove(fspec,unixified,tmplen+1);
8524 PerlMem_free(unixified);
8528 for (end = base; *end; end++) ; /* Find end of resultant filespec */
8529 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8530 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8531 for (cp1 = end ;cp1 >= base; cp1--)
8532 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8534 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8535 PerlMem_free(unixified);
8536 PerlMem_free(unixwild);
8541 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8542 int ells = 1, totells, segdirs, match;
8543 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8544 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8546 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8548 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8549 tpl = PerlMem_malloc(VMS_MAXRSS);
8550 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8551 if (ellipsis == template && opts & 1) {
8552 /* Template begins with an ellipsis. Since we can't tell how many
8553 * directory names at the front of the resultant to keep for an
8554 * arbitrary starting point, we arbitrarily choose the current
8555 * default directory as a starting point. If it's there as a prefix,
8556 * clip it off. If not, fall through and act as if the leading
8557 * ellipsis weren't there (i.e. return shortest possible path that
8558 * could match template).
8560 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8562 PerlMem_free(unixified);
8563 PerlMem_free(unixwild);
8566 if (!decc_efs_case_preserve) {
8567 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8568 if (_tolower(*cp1) != _tolower(*cp2)) break;
8570 segdirs = dirs - totells; /* Min # of dirs we must have left */
8571 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8572 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8573 memmove(fspec,cp2+1,end - cp2);
8575 PerlMem_free(unixified);
8576 PerlMem_free(unixwild);
8580 /* First off, back up over constant elements at end of path */
8582 for (front = end ; front >= base; front--)
8583 if (*front == '/' && !dirs--) { front++; break; }
8585 lcres = PerlMem_malloc(VMS_MAXRSS);
8586 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8587 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8589 if (!decc_efs_case_preserve) {
8590 *cp2 = _tolower(*cp1); /* Make lc copy for match */
8598 PerlMem_free(unixified);
8599 PerlMem_free(unixwild);
8600 PerlMem_free(lcres);
8601 return 0; /* Path too long. */
8604 *cp2 = '\0'; /* Pick up with memcpy later */
8605 lcfront = lcres + (front - base);
8606 /* Now skip over each ellipsis and try to match the path in front of it. */
8608 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8609 if (*(cp1) == '.' && *(cp1+1) == '.' &&
8610 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
8611 if (cp1 < template) break; /* template started with an ellipsis */
8612 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8613 ellipsis = cp1; continue;
8615 wilddsc.dsc$a_pointer = tpl;
8616 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8618 for (segdirs = 0, cp2 = tpl;
8619 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8621 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8623 if (!decc_efs_case_preserve) {
8624 *cp2 = _tolower(*cp1); /* else lowercase for match */
8627 *cp2 = *cp1; /* else preserve case for match */
8630 if (*cp2 == '/') segdirs++;
8632 if (cp1 != ellipsis - 1) {
8634 PerlMem_free(unixified);
8635 PerlMem_free(unixwild);
8636 PerlMem_free(lcres);
8637 return 0; /* Path too long */
8639 /* Back up at least as many dirs as in template before matching */
8640 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8641 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8642 for (match = 0; cp1 > lcres;) {
8643 resdsc.dsc$a_pointer = cp1;
8644 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8646 if (match == 1) lcfront = cp1;
8648 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8652 PerlMem_free(unixified);
8653 PerlMem_free(unixwild);
8654 PerlMem_free(lcres);
8655 return 0; /* Can't find prefix ??? */
8657 if (match > 1 && opts & 1) {
8658 /* This ... wildcard could cover more than one set of dirs (i.e.
8659 * a set of similar dir names is repeated). If the template
8660 * contains more than 1 ..., upstream elements could resolve the
8661 * ambiguity, but it's not worth a full backtracking setup here.
8662 * As a quick heuristic, clip off the current default directory
8663 * if it's present to find the trimmed spec, else use the
8664 * shortest string that this ... could cover.
8666 char def[NAM$C_MAXRSS+1], *st;
8668 if (getcwd(def, sizeof def,0) == NULL) {
8669 Safefree(unixified);
8675 if (!decc_efs_case_preserve) {
8676 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8677 if (_tolower(*cp1) != _tolower(*cp2)) break;
8679 segdirs = dirs - totells; /* Min # of dirs we must have left */
8680 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8681 if (*cp1 == '\0' && *cp2 == '/') {
8682 memmove(fspec,cp2+1,end - cp2);
8684 PerlMem_free(unixified);
8685 PerlMem_free(unixwild);
8686 PerlMem_free(lcres);
8689 /* Nope -- stick with lcfront from above and keep going. */
8692 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8694 PerlMem_free(unixified);
8695 PerlMem_free(unixwild);
8696 PerlMem_free(lcres);
8701 } /* end of trim_unixpath() */
8706 * VMS readdir() routines.
8707 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8709 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
8710 * Minor modifications to original routines.
8713 /* readdir may have been redefined by reentr.h, so make sure we get
8714 * the local version for what we do here.
8719 #if !defined(PERL_IMPLICIT_CONTEXT)
8720 # define readdir Perl_readdir
8722 # define readdir(a) Perl_readdir(aTHX_ a)
8725 /* Number of elements in vms_versions array */
8726 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
8729 * Open a directory, return a handle for later use.
8731 /*{{{ DIR *opendir(char*name) */
8733 Perl_opendir(pTHX_ const char *name)
8741 if (decc_efs_charset) {
8742 unix_flag = is_unix_filespec(name);
8745 Newx(dir, VMS_MAXRSS, char);
8746 if (do_tovmspath(name,dir,0,NULL) == NULL) {
8750 /* Check access before stat; otherwise stat does not
8751 * accurately report whether it's a directory.
8753 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8754 /* cando_by_name has already set errno */
8758 if (flex_stat(dir,&sb) == -1) return NULL;
8759 if (!S_ISDIR(sb.st_mode)) {
8761 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
8764 /* Get memory for the handle, and the pattern. */
8766 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8768 /* Fill in the fields; mainly playing with the descriptor. */
8769 sprintf(dd->pattern, "%s*.*",dir);
8775 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8776 dd->pat.dsc$a_pointer = dd->pattern;
8777 dd->pat.dsc$w_length = strlen(dd->pattern);
8778 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8779 dd->pat.dsc$b_class = DSC$K_CLASS_S;
8780 #if defined(USE_ITHREADS)
8781 Newx(dd->mutex,1,perl_mutex);
8782 MUTEX_INIT( (perl_mutex *) dd->mutex );
8788 } /* end of opendir() */
8792 * Set the flag to indicate we want versions or not.
8794 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8796 vmsreaddirversions(DIR *dd, int flag)
8799 dd->flags |= PERL_VMSDIR_M_VERSIONS;
8801 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8806 * Free up an opened directory.
8808 /*{{{ void closedir(DIR *dd)*/
8810 Perl_closedir(DIR *dd)
8814 sts = lib$find_file_end(&dd->context);
8815 Safefree(dd->pattern);
8816 #if defined(USE_ITHREADS)
8817 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8818 Safefree(dd->mutex);
8825 * Collect all the version numbers for the current file.
8828 collectversions(pTHX_ DIR *dd)
8830 struct dsc$descriptor_s pat;
8831 struct dsc$descriptor_s res;
8833 char *p, *text, *buff;
8835 unsigned long context, tmpsts;
8837 /* Convenient shorthand. */
8840 /* Add the version wildcard, ignoring the "*.*" put on before */
8841 i = strlen(dd->pattern);
8842 Newx(text,i + e->d_namlen + 3,char);
8843 strcpy(text, dd->pattern);
8844 sprintf(&text[i - 3], "%s;*", e->d_name);
8846 /* Set up the pattern descriptor. */
8847 pat.dsc$a_pointer = text;
8848 pat.dsc$w_length = i + e->d_namlen - 1;
8849 pat.dsc$b_dtype = DSC$K_DTYPE_T;
8850 pat.dsc$b_class = DSC$K_CLASS_S;
8852 /* Set up result descriptor. */
8853 Newx(buff, VMS_MAXRSS, char);
8854 res.dsc$a_pointer = buff;
8855 res.dsc$w_length = VMS_MAXRSS - 1;
8856 res.dsc$b_dtype = DSC$K_DTYPE_T;
8857 res.dsc$b_class = DSC$K_CLASS_S;
8859 /* Read files, collecting versions. */
8860 for (context = 0, e->vms_verscount = 0;
8861 e->vms_verscount < VERSIZE(e);
8862 e->vms_verscount++) {
8864 unsigned long flags = 0;
8866 #ifdef VMS_LONGNAME_SUPPORT
8867 flags = LIB$M_FIL_LONG_NAMES;
8869 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8870 if (tmpsts == RMS$_NMF || context == 0) break;
8872 buff[VMS_MAXRSS - 1] = '\0';
8873 if ((p = strchr(buff, ';')))
8874 e->vms_versions[e->vms_verscount] = atoi(p + 1);
8876 e->vms_versions[e->vms_verscount] = -1;
8879 _ckvmssts(lib$find_file_end(&context));
8883 } /* end of collectversions() */
8886 * Read the next entry from the directory.
8888 /*{{{ struct dirent *readdir(DIR *dd)*/
8890 Perl_readdir(pTHX_ DIR *dd)
8892 struct dsc$descriptor_s res;
8894 unsigned long int tmpsts;
8896 unsigned long flags = 0;
8897 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8898 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8900 /* Set up result descriptor, and get next file. */
8901 Newx(buff, VMS_MAXRSS, char);
8902 res.dsc$a_pointer = buff;
8903 res.dsc$w_length = VMS_MAXRSS - 1;
8904 res.dsc$b_dtype = DSC$K_DTYPE_T;
8905 res.dsc$b_class = DSC$K_CLASS_S;
8907 #ifdef VMS_LONGNAME_SUPPORT
8908 flags = LIB$M_FIL_LONG_NAMES;
8911 tmpsts = lib$find_file
8912 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8913 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
8914 if (!(tmpsts & 1)) {
8915 set_vaxc_errno(tmpsts);
8918 set_errno(EACCES); break;
8920 set_errno(ENODEV); break;
8922 set_errno(ENOTDIR); break;
8923 case RMS$_FNF: case RMS$_DNF:
8924 set_errno(ENOENT); break;
8932 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8933 if (!decc_efs_case_preserve) {
8934 buff[VMS_MAXRSS - 1] = '\0';
8935 for (p = buff; *p; p++) *p = _tolower(*p);
8938 /* we don't want to force to lowercase, just null terminate */
8939 buff[res.dsc$w_length] = '\0';
8941 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
8944 /* Skip any directory component and just copy the name. */
8945 sts = vms_split_path
8960 /* Drop NULL extensions on UNIX file specification */
8961 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8962 (e_len == 1) && decc_readdir_dropdotnotype)) {
8967 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8968 dd->entry.d_name[n_len + e_len] = '\0';
8969 dd->entry.d_namlen = strlen(dd->entry.d_name);
8971 /* Convert the filename to UNIX format if needed */
8972 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8974 /* Translate the encoded characters. */
8975 /* Fixme: unicode handling could result in embedded 0 characters */
8976 if (strchr(dd->entry.d_name, '^') != NULL) {
8980 p = dd->entry.d_name;
8984 x = copy_expand_vms_filename_escape(q, p, &y);
8988 /* if y > 1, then this is a wide file specification */
8989 /* Wide file specifications need to be passed in Perl */
8990 /* counted strings apparently with a unicode flag */
8993 strcpy(dd->entry.d_name, new_name);
8997 dd->entry.vms_verscount = 0;
8998 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9002 } /* end of readdir() */
9006 * Read the next entry from the directory -- thread-safe version.
9008 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9010 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9014 MUTEX_LOCK( (perl_mutex *) dd->mutex );
9016 entry = readdir(dd);
9018 retval = ( *result == NULL ? errno : 0 );
9020 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9024 } /* end of readdir_r() */
9028 * Return something that can be used in a seekdir later.
9030 /*{{{ long telldir(DIR *dd)*/
9032 Perl_telldir(DIR *dd)
9039 * Return to a spot where we used to be. Brute force.
9041 /*{{{ void seekdir(DIR *dd,long count)*/
9043 Perl_seekdir(pTHX_ DIR *dd, long count)
9047 /* If we haven't done anything yet... */
9051 /* Remember some state, and clear it. */
9052 old_flags = dd->flags;
9053 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9054 _ckvmssts(lib$find_file_end(&dd->context));
9057 /* The increment is in readdir(). */
9058 for (dd->count = 0; dd->count < count; )
9061 dd->flags = old_flags;
9063 } /* end of seekdir() */
9066 /* VMS subprocess management
9068 * my_vfork() - just a vfork(), after setting a flag to record that
9069 * the current script is trying a Unix-style fork/exec.
9071 * vms_do_aexec() and vms_do_exec() are called in response to the
9072 * perl 'exec' function. If this follows a vfork call, then they
9073 * call out the regular perl routines in doio.c which do an
9074 * execvp (for those who really want to try this under VMS).
9075 * Otherwise, they do exactly what the perl docs say exec should
9076 * do - terminate the current script and invoke a new command
9077 * (See below for notes on command syntax.)
9079 * do_aspawn() and do_spawn() implement the VMS side of the perl
9080 * 'system' function.
9082 * Note on command arguments to perl 'exec' and 'system': When handled
9083 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9084 * are concatenated to form a DCL command string. If the first arg
9085 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9086 * the command string is handed off to DCL directly. Otherwise,
9087 * the first token of the command is taken as the filespec of an image
9088 * to run. The filespec is expanded using a default type of '.EXE' and
9089 * the process defaults for device, directory, etc., and if found, the resultant
9090 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9091 * the command string as parameters. This is perhaps a bit complicated,
9092 * but I hope it will form a happy medium between what VMS folks expect
9093 * from lib$spawn and what Unix folks expect from exec.
9096 static int vfork_called;
9098 /*{{{int my_vfork()*/
9109 vms_execfree(struct dsc$descriptor_s *vmscmd)
9112 if (vmscmd->dsc$a_pointer) {
9113 PerlMem_free(vmscmd->dsc$a_pointer);
9115 PerlMem_free(vmscmd);
9120 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9122 char *junk, *tmps = Nullch;
9123 register size_t cmdlen = 0;
9130 tmps = SvPV(really,rlen);
9137 for (idx++; idx <= sp; idx++) {
9139 junk = SvPVx(*idx,rlen);
9140 cmdlen += rlen ? rlen + 1 : 0;
9143 Newx(PL_Cmd, cmdlen+1, char);
9145 if (tmps && *tmps) {
9146 strcpy(PL_Cmd,tmps);
9149 else *PL_Cmd = '\0';
9150 while (++mark <= sp) {
9152 char *s = SvPVx(*mark,n_a);
9154 if (*PL_Cmd) strcat(PL_Cmd," ");
9160 } /* end of setup_argstr() */
9163 static unsigned long int
9164 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9165 struct dsc$descriptor_s **pvmscmd)
9167 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9168 char image_name[NAM$C_MAXRSS+1];
9169 char image_argv[NAM$C_MAXRSS+1];
9170 $DESCRIPTOR(defdsc,".EXE");
9171 $DESCRIPTOR(defdsc2,".");
9172 $DESCRIPTOR(resdsc,resspec);
9173 struct dsc$descriptor_s *vmscmd;
9174 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9175 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9176 register char *s, *rest, *cp, *wordbreak;
9181 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9182 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9184 /* Make a copy for modification */
9185 cmdlen = strlen(incmd);
9186 cmd = PerlMem_malloc(cmdlen+1);
9187 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9188 strncpy(cmd, incmd, cmdlen);
9193 vmscmd->dsc$a_pointer = NULL;
9194 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
9195 vmscmd->dsc$b_class = DSC$K_CLASS_S;
9196 vmscmd->dsc$w_length = 0;
9197 if (pvmscmd) *pvmscmd = vmscmd;
9199 if (suggest_quote) *suggest_quote = 0;
9201 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9203 return CLI$_BUFOVF; /* continuation lines currently unsupported */
9208 while (*s && isspace(*s)) s++;
9210 if (*s == '@' || *s == '$') {
9211 vmsspec[0] = *s; rest = s + 1;
9212 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9214 else { cp = vmsspec; rest = s; }
9215 if (*rest == '.' || *rest == '/') {
9218 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9219 rest++, cp2++) *cp2 = *rest;
9221 if (do_tovmsspec(resspec,cp,0,NULL)) {
9224 for (cp2 = vmsspec + strlen(vmsspec);
9225 *rest && cp2 - vmsspec < sizeof vmsspec;
9226 rest++, cp2++) *cp2 = *rest;
9231 /* Intuit whether verb (first word of cmd) is a DCL command:
9232 * - if first nonspace char is '@', it's a DCL indirection
9234 * - if verb contains a filespec separator, it's not a DCL command
9235 * - if it doesn't, caller tells us whether to default to a DCL
9236 * command, or to a local image unless told it's DCL (by leading '$')
9240 if (suggest_quote) *suggest_quote = 1;
9242 register char *filespec = strpbrk(s,":<[.;");
9243 rest = wordbreak = strpbrk(s," \"\t/");
9244 if (!wordbreak) wordbreak = s + strlen(s);
9245 if (*s == '$') check_img = 0;
9246 if (filespec && (filespec < wordbreak)) isdcl = 0;
9247 else isdcl = !check_img;
9252 imgdsc.dsc$a_pointer = s;
9253 imgdsc.dsc$w_length = wordbreak - s;
9254 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9256 _ckvmssts(lib$find_file_end(&cxt));
9257 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9258 if (!(retsts & 1) && *s == '$') {
9259 _ckvmssts(lib$find_file_end(&cxt));
9260 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9261 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9263 _ckvmssts(lib$find_file_end(&cxt));
9264 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9268 _ckvmssts(lib$find_file_end(&cxt));
9273 while (*s && !isspace(*s)) s++;
9276 /* check that it's really not DCL with no file extension */
9277 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9279 char b[256] = {0,0,0,0};
9280 read(fileno(fp), b, 256);
9281 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9285 /* Check for script */
9287 if ((b[0] == '#') && (b[1] == '!'))
9289 #ifdef ALTERNATE_SHEBANG
9291 shebang_len = strlen(ALTERNATE_SHEBANG);
9292 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9294 perlstr = strstr("perl",b);
9295 if (perlstr == NULL)
9303 if (shebang_len > 0) {
9306 char tmpspec[NAM$C_MAXRSS + 1];
9309 /* Image is following after white space */
9310 /*--------------------------------------*/
9311 while (isprint(b[i]) && isspace(b[i]))
9315 while (isprint(b[i]) && !isspace(b[i])) {
9316 tmpspec[j++] = b[i++];
9317 if (j >= NAM$C_MAXRSS)
9322 /* There may be some default parameters to the image */
9323 /*---------------------------------------------------*/
9325 while (isprint(b[i])) {
9326 image_argv[j++] = b[i++];
9327 if (j >= NAM$C_MAXRSS)
9330 while ((j > 0) && !isprint(image_argv[j-1]))
9334 /* It will need to be converted to VMS format and validated */
9335 if (tmpspec[0] != '\0') {
9338 /* Try to find the exact program requested to be run */
9339 /*---------------------------------------------------*/
9340 iname = do_rmsexpand
9341 (tmpspec, image_name, 0, ".exe",
9342 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9343 if (iname != NULL) {
9344 if (cando_by_name_int
9345 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9346 /* MCR prefix needed */
9350 /* Try again with a null type */
9351 /*----------------------------*/
9352 iname = do_rmsexpand
9353 (tmpspec, image_name, 0, ".",
9354 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9355 if (iname != NULL) {
9356 if (cando_by_name_int
9357 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9358 /* MCR prefix needed */
9364 /* Did we find the image to run the script? */
9365 /*------------------------------------------*/
9369 /* Assume DCL or foreign command exists */
9370 /*--------------------------------------*/
9371 tchr = strrchr(tmpspec, '/');
9378 strcpy(image_name, tchr);
9386 if (check_img && isdcl) return RMS$_FNF;
9388 if (cando_by_name(S_IXUSR,0,resspec)) {
9389 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9390 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9392 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9393 if (image_name[0] != 0) {
9394 strcat(vmscmd->dsc$a_pointer, image_name);
9395 strcat(vmscmd->dsc$a_pointer, " ");
9397 } else if (image_name[0] != 0) {
9398 strcpy(vmscmd->dsc$a_pointer, image_name);
9399 strcat(vmscmd->dsc$a_pointer, " ");
9401 strcpy(vmscmd->dsc$a_pointer,"@");
9403 if (suggest_quote) *suggest_quote = 1;
9405 /* If there is an image name, use original command */
9406 if (image_name[0] == 0)
9407 strcat(vmscmd->dsc$a_pointer,resspec);
9410 while (*rest && isspace(*rest)) rest++;
9413 if (image_argv[0] != 0) {
9414 strcat(vmscmd->dsc$a_pointer,image_argv);
9415 strcat(vmscmd->dsc$a_pointer, " ");
9421 rest_len = strlen(rest);
9422 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9423 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9424 strcat(vmscmd->dsc$a_pointer,rest);
9426 retsts = CLI$_BUFOVF;
9428 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9430 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9436 /* It's either a DCL command or we couldn't find a suitable image */
9437 vmscmd->dsc$w_length = strlen(cmd);
9439 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9440 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9441 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9445 /* check if it's a symbol (for quoting purposes) */
9446 if (suggest_quote && !*suggest_quote) {
9448 char equiv[LNM$C_NAMLENGTH];
9449 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9450 eqvdsc.dsc$a_pointer = equiv;
9452 iss = lib$get_symbol(vmscmd,&eqvdsc);
9453 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9455 if (!(retsts & 1)) {
9456 /* just hand off status values likely to be due to user error */
9457 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9458 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9459 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9460 else { _ckvmssts(retsts); }
9463 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9465 } /* end of setup_cmddsc() */
9468 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9470 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9476 if (vfork_called) { /* this follows a vfork - act Unixish */
9478 if (vfork_called < 0) {
9479 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9482 else return do_aexec(really,mark,sp);
9484 /* no vfork - act VMSish */
9485 cmd = setup_argstr(aTHX_ really,mark,sp);
9486 exec_sts = vms_do_exec(cmd);
9487 Safefree(cmd); /* Clean up from setup_argstr() */
9492 } /* end of vms_do_aexec() */
9495 /* {{{bool vms_do_exec(char *cmd) */
9497 Perl_vms_do_exec(pTHX_ const char *cmd)
9499 struct dsc$descriptor_s *vmscmd;
9501 if (vfork_called) { /* this follows a vfork - act Unixish */
9503 if (vfork_called < 0) {
9504 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9507 else return do_exec(cmd);
9510 { /* no vfork - act VMSish */
9511 unsigned long int retsts;
9514 TAINT_PROPER("exec");
9515 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9516 retsts = lib$do_command(vmscmd);
9519 case RMS$_FNF: case RMS$_DNF:
9520 set_errno(ENOENT); break;
9522 set_errno(ENOTDIR); break;
9524 set_errno(ENODEV); break;
9526 set_errno(EACCES); break;
9528 set_errno(EINVAL); break;
9529 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9530 set_errno(E2BIG); break;
9531 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9532 _ckvmssts(retsts); /* fall through */
9533 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9536 set_vaxc_errno(retsts);
9537 if (ckWARN(WARN_EXEC)) {
9538 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9539 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9541 vms_execfree(vmscmd);
9546 } /* end of vms_do_exec() */
9549 unsigned long int Perl_do_spawn(pTHX_ const char *);
9551 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9553 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9555 unsigned long int sts;
9559 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9560 sts = do_spawn(cmd);
9561 /* pp_sys will clean up cmd */
9565 } /* end of do_aspawn() */
9568 /* {{{unsigned long int do_spawn(char *cmd) */
9570 Perl_do_spawn(pTHX_ const char *cmd)
9572 unsigned long int sts, substs;
9574 /* The caller of this routine expects to Safefree(PL_Cmd) */
9575 Newx(PL_Cmd,10,char);
9578 TAINT_PROPER("spawn");
9579 if (!cmd || !*cmd) {
9580 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9583 case RMS$_FNF: case RMS$_DNF:
9584 set_errno(ENOENT); break;
9586 set_errno(ENOTDIR); break;
9588 set_errno(ENODEV); break;
9590 set_errno(EACCES); break;
9592 set_errno(EINVAL); break;
9593 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9594 set_errno(E2BIG); break;
9595 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9596 _ckvmssts(sts); /* fall through */
9597 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9600 set_vaxc_errno(sts);
9601 if (ckWARN(WARN_EXEC)) {
9602 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9610 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9615 } /* end of do_spawn() */
9619 static unsigned int *sockflags, sockflagsize;
9622 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9623 * routines found in some versions of the CRTL can't deal with sockets.
9624 * We don't shim the other file open routines since a socket isn't
9625 * likely to be opened by a name.
9627 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9628 FILE *my_fdopen(int fd, const char *mode)
9630 FILE *fp = fdopen(fd, mode);
9633 unsigned int fdoff = fd / sizeof(unsigned int);
9634 Stat_t sbuf; /* native stat; we don't need flex_stat */
9635 if (!sockflagsize || fdoff > sockflagsize) {
9636 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
9637 else Newx (sockflags,fdoff+2,unsigned int);
9638 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9639 sockflagsize = fdoff + 2;
9641 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9642 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9651 * Clear the corresponding bit when the (possibly) socket stream is closed.
9652 * There still a small hole: we miss an implicit close which might occur
9653 * via freopen(). >> Todo
9655 /*{{{ int my_fclose(FILE *fp)*/
9656 int my_fclose(FILE *fp) {
9658 unsigned int fd = fileno(fp);
9659 unsigned int fdoff = fd / sizeof(unsigned int);
9661 if (sockflagsize && fdoff <= sockflagsize)
9662 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9670 * A simple fwrite replacement which outputs itmsz*nitm chars without
9671 * introducing record boundaries every itmsz chars.
9672 * We are using fputs, which depends on a terminating null. We may
9673 * well be writing binary data, so we need to accommodate not only
9674 * data with nulls sprinkled in the middle but also data with no null
9677 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9679 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9681 register char *cp, *end, *cpd, *data;
9682 register unsigned int fd = fileno(dest);
9683 register unsigned int fdoff = fd / sizeof(unsigned int);
9685 int bufsize = itmsz * nitm + 1;
9687 if (fdoff < sockflagsize &&
9688 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9689 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9693 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9694 memcpy( data, src, itmsz*nitm );
9695 data[itmsz*nitm] = '\0';
9697 end = data + itmsz * nitm;
9698 retval = (int) nitm; /* on success return # items written */
9701 while (cpd <= end) {
9702 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9703 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9705 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9709 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9712 } /* end of my_fwrite() */
9715 /*{{{ int my_flush(FILE *fp)*/
9717 Perl_my_flush(pTHX_ FILE *fp)
9720 if ((res = fflush(fp)) == 0 && fp) {
9721 #ifdef VMS_DO_SOCKETS
9723 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9725 res = fsync(fileno(fp));
9728 * If the flush succeeded but set end-of-file, we need to clear
9729 * the error because our caller may check ferror(). BTW, this
9730 * probably means we just flushed an empty file.
9732 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9739 * Here are replacements for the following Unix routines in the VMS environment:
9740 * getpwuid Get information for a particular UIC or UID
9741 * getpwnam Get information for a named user
9742 * getpwent Get information for each user in the rights database
9743 * setpwent Reset search to the start of the rights database
9744 * endpwent Finish searching for users in the rights database
9746 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9747 * (defined in pwd.h), which contains the following fields:-
9749 * char *pw_name; Username (in lower case)
9750 * char *pw_passwd; Hashed password
9751 * unsigned int pw_uid; UIC
9752 * unsigned int pw_gid; UIC group number
9753 * char *pw_unixdir; Default device/directory (VMS-style)
9754 * char *pw_gecos; Owner name
9755 * char *pw_dir; Default device/directory (Unix-style)
9756 * char *pw_shell; Default CLI name (eg. DCL)
9758 * If the specified user does not exist, getpwuid and getpwnam return NULL.
9760 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9761 * not the UIC member number (eg. what's returned by getuid()),
9762 * getpwuid() can accept either as input (if uid is specified, the caller's
9763 * UIC group is used), though it won't recognise gid=0.
9765 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9766 * information about other users in your group or in other groups, respectively.
9767 * If the required privilege is not available, then these routines fill only
9768 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9771 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9774 /* sizes of various UAF record fields */
9775 #define UAI$S_USERNAME 12
9776 #define UAI$S_IDENT 31
9777 #define UAI$S_OWNER 31
9778 #define UAI$S_DEFDEV 31
9779 #define UAI$S_DEFDIR 63
9780 #define UAI$S_DEFCLI 31
9783 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
9784 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9785 (uic).uic$v_group != UIC$K_WILD_GROUP)
9787 static char __empty[]= "";
9788 static struct passwd __passwd_empty=
9789 {(char *) __empty, (char *) __empty, 0, 0,
9790 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9791 static int contxt= 0;
9792 static struct passwd __pwdcache;
9793 static char __pw_namecache[UAI$S_IDENT+1];
9796 * This routine does most of the work extracting the user information.
9798 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9801 unsigned char length;
9802 char pw_gecos[UAI$S_OWNER+1];
9804 static union uicdef uic;
9806 unsigned char length;
9807 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9810 unsigned char length;
9811 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9814 unsigned char length;
9815 char pw_shell[UAI$S_DEFCLI+1];
9817 static char pw_passwd[UAI$S_PWD+1];
9819 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9820 struct dsc$descriptor_s name_desc;
9821 unsigned long int sts;
9823 static struct itmlst_3 itmlst[]= {
9824 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
9825 {sizeof(uic), UAI$_UIC, &uic, &luic},
9826 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
9827 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
9828 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
9829 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
9830 {0, 0, NULL, NULL}};
9832 name_desc.dsc$w_length= strlen(name);
9833 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9834 name_desc.dsc$b_class= DSC$K_CLASS_S;
9835 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9837 /* Note that sys$getuai returns many fields as counted strings. */
9838 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9839 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9840 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9842 else { _ckvmssts(sts); }
9843 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
9845 if ((int) owner.length < lowner) lowner= (int) owner.length;
9846 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9847 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9848 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9849 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9850 owner.pw_gecos[lowner]= '\0';
9851 defdev.pw_dir[ldefdev+ldefdir]= '\0';
9852 defcli.pw_shell[ldefcli]= '\0';
9853 if (valid_uic(uic)) {
9854 pwd->pw_uid= uic.uic$l_uic;
9855 pwd->pw_gid= uic.uic$v_group;
9858 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9859 pwd->pw_passwd= pw_passwd;
9860 pwd->pw_gecos= owner.pw_gecos;
9861 pwd->pw_dir= defdev.pw_dir;
9862 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9863 pwd->pw_shell= defcli.pw_shell;
9864 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9866 ldir= strlen(pwd->pw_unixdir) - 1;
9867 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9870 strcpy(pwd->pw_unixdir, pwd->pw_dir);
9871 if (!decc_efs_case_preserve)
9872 __mystrtolower(pwd->pw_unixdir);
9877 * Get information for a named user.
9879 /*{{{struct passwd *getpwnam(char *name)*/
9880 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9882 struct dsc$descriptor_s name_desc;
9884 unsigned long int status, sts;
9886 __pwdcache = __passwd_empty;
9887 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9888 /* We still may be able to determine pw_uid and pw_gid */
9889 name_desc.dsc$w_length= strlen(name);
9890 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9891 name_desc.dsc$b_class= DSC$K_CLASS_S;
9892 name_desc.dsc$a_pointer= (char *) name;
9893 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9894 __pwdcache.pw_uid= uic.uic$l_uic;
9895 __pwdcache.pw_gid= uic.uic$v_group;
9898 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9899 set_vaxc_errno(sts);
9900 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9903 else { _ckvmssts(sts); }
9906 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9907 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9908 __pwdcache.pw_name= __pw_namecache;
9910 } /* end of my_getpwnam() */
9914 * Get information for a particular UIC or UID.
9915 * Called by my_getpwent with uid=-1 to list all users.
9917 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9918 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9920 const $DESCRIPTOR(name_desc,__pw_namecache);
9921 unsigned short lname;
9923 unsigned long int status;
9925 if (uid == (unsigned int) -1) {
9927 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9928 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9929 set_vaxc_errno(status);
9930 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9934 else { _ckvmssts(status); }
9935 } while (!valid_uic (uic));
9939 if (!uic.uic$v_group)
9940 uic.uic$v_group= PerlProc_getgid();
9942 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9943 else status = SS$_IVIDENT;
9944 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9945 status == RMS$_PRV) {
9946 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9949 else { _ckvmssts(status); }
9951 __pw_namecache[lname]= '\0';
9952 __mystrtolower(__pw_namecache);
9954 __pwdcache = __passwd_empty;
9955 __pwdcache.pw_name = __pw_namecache;
9957 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9958 The identifier's value is usually the UIC, but it doesn't have to be,
9959 so if we can, we let fillpasswd update this. */
9960 __pwdcache.pw_uid = uic.uic$l_uic;
9961 __pwdcache.pw_gid = uic.uic$v_group;
9963 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9966 } /* end of my_getpwuid() */
9970 * Get information for next user.
9972 /*{{{struct passwd *my_getpwent()*/
9973 struct passwd *Perl_my_getpwent(pTHX)
9975 return (my_getpwuid((unsigned int) -1));
9980 * Finish searching rights database for users.
9982 /*{{{void my_endpwent()*/
9983 void Perl_my_endpwent(pTHX)
9986 _ckvmssts(sys$finish_rdb(&contxt));
9992 #ifdef HOMEGROWN_POSIX_SIGNALS
9993 /* Signal handling routines, pulled into the core from POSIX.xs.
9995 * We need these for threads, so they've been rolled into the core,
9996 * rather than left in POSIX.xs.
9998 * (DRS, Oct 23, 1997)
10001 /* sigset_t is atomic under VMS, so these routines are easy */
10002 /*{{{int my_sigemptyset(sigset_t *) */
10003 int my_sigemptyset(sigset_t *set) {
10004 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10005 *set = 0; return 0;
10010 /*{{{int my_sigfillset(sigset_t *)*/
10011 int my_sigfillset(sigset_t *set) {
10013 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10014 for (i = 0; i < NSIG; i++) *set |= (1 << i);
10020 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10021 int my_sigaddset(sigset_t *set, int sig) {
10022 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10023 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10024 *set |= (1 << (sig - 1));
10030 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10031 int my_sigdelset(sigset_t *set, int sig) {
10032 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10033 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10034 *set &= ~(1 << (sig - 1));
10040 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10041 int my_sigismember(sigset_t *set, int sig) {
10042 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10043 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10044 return *set & (1 << (sig - 1));
10049 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10050 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10053 /* If set and oset are both null, then things are badly wrong. Bail out. */
10054 if ((oset == NULL) && (set == NULL)) {
10055 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10059 /* If set's null, then we're just handling a fetch. */
10061 tempmask = sigblock(0);
10066 tempmask = sigsetmask(*set);
10069 tempmask = sigblock(*set);
10072 tempmask = sigblock(0);
10073 sigsetmask(*oset & ~tempmask);
10076 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10081 /* Did they pass us an oset? If so, stick our holding mask into it */
10088 #endif /* HOMEGROWN_POSIX_SIGNALS */
10091 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10092 * my_utime(), and flex_stat(), all of which operate on UTC unless
10093 * VMSISH_TIMES is true.
10095 /* method used to handle UTC conversions:
10096 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
10098 static int gmtime_emulation_type;
10099 /* number of secs to add to UTC POSIX-style time to get local time */
10100 static long int utc_offset_secs;
10102 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10103 * in vmsish.h. #undef them here so we can call the CRTL routines
10112 * DEC C previous to 6.0 corrupts the behavior of the /prefix
10113 * qualifier with the extern prefix pragma. This provisional
10114 * hack circumvents this prefix pragma problem in previous
10117 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10118 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10119 # pragma __extern_prefix save
10120 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
10121 # define gmtime decc$__utctz_gmtime
10122 # define localtime decc$__utctz_localtime
10123 # define time decc$__utc_time
10124 # pragma __extern_prefix restore
10126 struct tm *gmtime(), *localtime();
10132 static time_t toutc_dst(time_t loc) {
10135 if ((rsltmp = localtime(&loc)) == NULL) return -1;
10136 loc -= utc_offset_secs;
10137 if (rsltmp->tm_isdst) loc -= 3600;
10140 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10141 ((gmtime_emulation_type || my_time(NULL)), \
10142 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10143 ((secs) - utc_offset_secs))))
10145 static time_t toloc_dst(time_t utc) {
10148 utc += utc_offset_secs;
10149 if ((rsltmp = localtime(&utc)) == NULL) return -1;
10150 if (rsltmp->tm_isdst) utc += 3600;
10153 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10154 ((gmtime_emulation_type || my_time(NULL)), \
10155 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10156 ((secs) + utc_offset_secs))))
10158 #ifndef RTL_USES_UTC
10161 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
10162 DST starts on 1st sun of april at 02:00 std time
10163 ends on last sun of october at 02:00 dst time
10164 see the UCX management command reference, SET CONFIG TIMEZONE
10165 for formatting info.
10167 No, it's not as general as it should be, but then again, NOTHING
10168 will handle UK times in a sensible way.
10173 parse the DST start/end info:
10174 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10178 tz_parse_startend(char *s, struct tm *w, int *past)
10180 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10181 int ly, dozjd, d, m, n, hour, min, sec, j, k;
10186 if (!past) return 0;
10189 if (w->tm_year % 4 == 0) ly = 1;
10190 if (w->tm_year % 100 == 0) ly = 0;
10191 if (w->tm_year+1900 % 400 == 0) ly = 1;
10194 dozjd = isdigit(*s);
10195 if (*s == 'J' || *s == 'j' || dozjd) {
10196 if (!dozjd && !isdigit(*++s)) return 0;
10199 d = d*10 + *s++ - '0';
10201 d = d*10 + *s++ - '0';
10204 if (d == 0) return 0;
10205 if (d > 366) return 0;
10207 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
10210 } else if (*s == 'M' || *s == 'm') {
10211 if (!isdigit(*++s)) return 0;
10213 if (isdigit(*s)) m = 10*m + *s++ - '0';
10214 if (*s != '.') return 0;
10215 if (!isdigit(*++s)) return 0;
10217 if (n < 1 || n > 5) return 0;
10218 if (*s != '.') return 0;
10219 if (!isdigit(*++s)) return 0;
10221 if (d > 6) return 0;
10225 if (!isdigit(*++s)) return 0;
10227 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10229 if (!isdigit(*++s)) return 0;
10231 if (isdigit(*s)) min = 10*min + *s++ - '0';
10233 if (!isdigit(*++s)) return 0;
10235 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10245 if (w->tm_yday < d) goto before;
10246 if (w->tm_yday > d) goto after;
10248 if (w->tm_mon+1 < m) goto before;
10249 if (w->tm_mon+1 > m) goto after;
10251 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
10252 k = d - j; /* mday of first d */
10253 if (k <= 0) k += 7;
10254 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
10255 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10256 if (w->tm_mday < k) goto before;
10257 if (w->tm_mday > k) goto after;
10260 if (w->tm_hour < hour) goto before;
10261 if (w->tm_hour > hour) goto after;
10262 if (w->tm_min < min) goto before;
10263 if (w->tm_min > min) goto after;
10264 if (w->tm_sec < sec) goto before;
10278 /* parse the offset: (+|-)hh[:mm[:ss]] */
10281 tz_parse_offset(char *s, int *offset)
10283 int hour = 0, min = 0, sec = 0;
10286 if (!offset) return 0;
10288 if (*s == '-') {neg++; s++;}
10289 if (*s == '+') s++;
10290 if (!isdigit(*s)) return 0;
10292 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10293 if (hour > 24) return 0;
10295 if (!isdigit(*++s)) return 0;
10297 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10298 if (min > 59) return 0;
10300 if (!isdigit(*++s)) return 0;
10302 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10303 if (sec > 59) return 0;
10307 *offset = (hour*60+min)*60 + sec;
10308 if (neg) *offset = -*offset;
10313 input time is w, whatever type of time the CRTL localtime() uses.
10314 sets dst, the zone, and the gmtoff (seconds)
10316 caches the value of TZ and UCX$TZ env variables; note that
10317 my_setenv looks for these and sets a flag if they're changed
10320 We have to watch out for the "australian" case (dst starts in
10321 october, ends in april)...flagged by "reverse" and checked by
10322 scanning through the months of the previous year.
10327 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10332 char *dstzone, *tz, *s_start, *s_end;
10333 int std_off, dst_off, isdst;
10334 int y, dststart, dstend;
10335 static char envtz[1025]; /* longer than any logical, symbol, ... */
10336 static char ucxtz[1025];
10337 static char reversed = 0;
10343 reversed = -1; /* flag need to check */
10344 envtz[0] = ucxtz[0] = '\0';
10345 tz = my_getenv("TZ",0);
10346 if (tz) strcpy(envtz, tz);
10347 tz = my_getenv("UCX$TZ",0);
10348 if (tz) strcpy(ucxtz, tz);
10349 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
10352 if (!*tz) tz = ucxtz;
10355 while (isalpha(*s)) s++;
10356 s = tz_parse_offset(s, &std_off);
10358 if (!*s) { /* no DST, hurray we're done! */
10364 while (isalpha(*s)) s++;
10365 s2 = tz_parse_offset(s, &dst_off);
10369 dst_off = std_off - 3600;
10372 if (!*s) { /* default dst start/end?? */
10373 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
10374 s = strchr(ucxtz,',');
10376 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
10378 if (*s != ',') return 0;
10381 when = _toutc(when); /* convert to utc */
10382 when = when - std_off; /* convert to pseudolocal time*/
10384 w2 = localtime(&when);
10387 s = tz_parse_startend(s_start,w2,&dststart);
10389 if (*s != ',') return 0;
10392 when = _toutc(when); /* convert to utc */
10393 when = when - dst_off; /* convert to pseudolocal time*/
10394 w2 = localtime(&when);
10395 if (w2->tm_year != y) { /* spans a year, just check one time */
10396 when += dst_off - std_off;
10397 w2 = localtime(&when);
10400 s = tz_parse_startend(s_end,w2,&dstend);
10403 if (reversed == -1) { /* need to check if start later than end */
10407 if (when < 2*365*86400) {
10408 when += 2*365*86400;
10412 w2 =localtime(&when);
10413 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
10415 for (j = 0; j < 12; j++) {
10416 w2 =localtime(&when);
10417 tz_parse_startend(s_start,w2,&ds);
10418 tz_parse_startend(s_end,w2,&de);
10419 if (ds != de) break;
10423 if (de && !ds) reversed = 1;
10426 isdst = dststart && !dstend;
10427 if (reversed) isdst = dststart || !dstend;
10430 if (dst) *dst = isdst;
10431 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10432 if (isdst) tz = dstzone;
10434 while(isalpha(*tz)) *zone++ = *tz++;
10440 #endif /* !RTL_USES_UTC */
10442 /* my_time(), my_localtime(), my_gmtime()
10443 * By default traffic in UTC time values, using CRTL gmtime() or
10444 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10445 * Note: We need to use these functions even when the CRTL has working
10446 * UTC support, since they also handle C<use vmsish qw(times);>
10448 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
10449 * Modified by Charles Bailey <bailey@newman.upenn.edu>
10452 /*{{{time_t my_time(time_t *timep)*/
10453 time_t Perl_my_time(pTHX_ time_t *timep)
10458 if (gmtime_emulation_type == 0) {
10460 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
10461 /* results of calls to gmtime() and localtime() */
10462 /* for same &base */
10464 gmtime_emulation_type++;
10465 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10466 char off[LNM$C_NAMLENGTH+1];;
10468 gmtime_emulation_type++;
10469 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10470 gmtime_emulation_type++;
10471 utc_offset_secs = 0;
10472 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10474 else { utc_offset_secs = atol(off); }
10476 else { /* We've got a working gmtime() */
10477 struct tm gmt, local;
10480 tm_p = localtime(&base);
10482 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
10483 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10484 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
10485 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
10490 # ifdef VMSISH_TIME
10491 # ifdef RTL_USES_UTC
10492 if (VMSISH_TIME) when = _toloc(when);
10494 if (!VMSISH_TIME) when = _toutc(when);
10497 if (timep != NULL) *timep = when;
10500 } /* end of my_time() */
10504 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10506 Perl_my_gmtime(pTHX_ const time_t *timep)
10512 if (timep == NULL) {
10513 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10516 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10519 # ifdef VMSISH_TIME
10520 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10522 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
10523 return gmtime(&when);
10525 /* CRTL localtime() wants local time as input, so does no tz correction */
10526 rsltmp = localtime(&when);
10527 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
10530 } /* end of my_gmtime() */
10534 /*{{{struct tm *my_localtime(const time_t *timep)*/
10536 Perl_my_localtime(pTHX_ const time_t *timep)
10538 time_t when, whenutc;
10542 if (timep == NULL) {
10543 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10546 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10547 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10550 # ifdef RTL_USES_UTC
10551 # ifdef VMSISH_TIME
10552 if (VMSISH_TIME) when = _toutc(when);
10554 /* CRTL localtime() wants UTC as input, does tz correction itself */
10555 return localtime(&when);
10557 # else /* !RTL_USES_UTC */
10559 # ifdef VMSISH_TIME
10560 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
10561 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
10564 #ifndef RTL_USES_UTC
10565 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
10566 when = whenutc - offset; /* pseudolocal time*/
10569 /* CRTL localtime() wants local time as input, so does no tz correction */
10570 rsltmp = localtime(&when);
10571 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10575 } /* end of my_localtime() */
10578 /* Reset definitions for later calls */
10579 #define gmtime(t) my_gmtime(t)
10580 #define localtime(t) my_localtime(t)
10581 #define time(t) my_time(t)
10584 /* my_utime - update modification/access time of a file
10586 * VMS 7.3 and later implementation
10587 * Only the UTC translation is home-grown. The rest is handled by the
10588 * CRTL utime(), which will take into account the relevant feature
10589 * logicals and ODS-5 volume characteristics for true access times.
10591 * pre VMS 7.3 implementation:
10592 * The calling sequence is identical to POSIX utime(), but under
10593 * VMS with ODS-2, only the modification time is changed; ODS-2 does
10594 * not maintain access times. Restrictions differ from the POSIX
10595 * definition in that the time can be changed as long as the
10596 * caller has permission to execute the necessary IO$_MODIFY $QIO;
10597 * no separate checks are made to insure that the caller is the
10598 * owner of the file or has special privs enabled.
10599 * Code here is based on Joe Meadows' FILE utility.
10603 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10604 * to VMS epoch (01-JAN-1858 00:00:00.00)
10605 * in 100 ns intervals.
10607 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10609 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10610 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10612 #if __CRTL_VER >= 70300000
10613 struct utimbuf utc_utimes, *utc_utimesp;
10615 if (utimes != NULL) {
10616 utc_utimes.actime = utimes->actime;
10617 utc_utimes.modtime = utimes->modtime;
10618 # ifdef VMSISH_TIME
10619 /* If input was local; convert to UTC for sys svc */
10621 utc_utimes.actime = _toutc(utimes->actime);
10622 utc_utimes.modtime = _toutc(utimes->modtime);
10625 utc_utimesp = &utc_utimes;
10628 utc_utimesp = NULL;
10631 return utime(file, utc_utimesp);
10633 #else /* __CRTL_VER < 70300000 */
10637 long int bintime[2], len = 2, lowbit, unixtime,
10638 secscale = 10000000; /* seconds --> 100 ns intervals */
10639 unsigned long int chan, iosb[2], retsts;
10640 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10641 struct FAB myfab = cc$rms_fab;
10642 struct NAM mynam = cc$rms_nam;
10643 #if defined (__DECC) && defined (__VAX)
10644 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10645 * at least through VMS V6.1, which causes a type-conversion warning.
10647 # pragma message save
10648 # pragma message disable cvtdiftypes
10650 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10651 struct fibdef myfib;
10652 #if defined (__DECC) && defined (__VAX)
10653 /* This should be right after the declaration of myatr, but due
10654 * to a bug in VAX DEC C, this takes effect a statement early.
10656 # pragma message restore
10658 /* cast ok for read only parameter */
10659 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10660 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10661 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10663 if (file == NULL || *file == '\0') {
10664 SETERRNO(ENOENT, LIB$_INVARG);
10668 /* Convert to VMS format ensuring that it will fit in 255 characters */
10669 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10670 SETERRNO(ENOENT, LIB$_INVARG);
10673 if (utimes != NULL) {
10674 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
10675 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10676 * Since time_t is unsigned long int, and lib$emul takes a signed long int
10677 * as input, we force the sign bit to be clear by shifting unixtime right
10678 * one bit, then multiplying by an extra factor of 2 in lib$emul().
10680 lowbit = (utimes->modtime & 1) ? secscale : 0;
10681 unixtime = (long int) utimes->modtime;
10682 # ifdef VMSISH_TIME
10683 /* If input was UTC; convert to local for sys svc */
10684 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10686 unixtime >>= 1; secscale <<= 1;
10687 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10688 if (!(retsts & 1)) {
10689 SETERRNO(EVMSERR, retsts);
10692 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10693 if (!(retsts & 1)) {
10694 SETERRNO(EVMSERR, retsts);
10699 /* Just get the current time in VMS format directly */
10700 retsts = sys$gettim(bintime);
10701 if (!(retsts & 1)) {
10702 SETERRNO(EVMSERR, retsts);
10707 myfab.fab$l_fna = vmsspec;
10708 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10709 myfab.fab$l_nam = &mynam;
10710 mynam.nam$l_esa = esa;
10711 mynam.nam$b_ess = (unsigned char) sizeof esa;
10712 mynam.nam$l_rsa = rsa;
10713 mynam.nam$b_rss = (unsigned char) sizeof rsa;
10714 if (decc_efs_case_preserve)
10715 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10717 /* Look for the file to be affected, letting RMS parse the file
10718 * specification for us as well. I have set errno using only
10719 * values documented in the utime() man page for VMS POSIX.
10721 retsts = sys$parse(&myfab,0,0);
10722 if (!(retsts & 1)) {
10723 set_vaxc_errno(retsts);
10724 if (retsts == RMS$_PRV) set_errno(EACCES);
10725 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10726 else set_errno(EVMSERR);
10729 retsts = sys$search(&myfab,0,0);
10730 if (!(retsts & 1)) {
10731 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10732 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10733 set_vaxc_errno(retsts);
10734 if (retsts == RMS$_PRV) set_errno(EACCES);
10735 else if (retsts == RMS$_FNF) set_errno(ENOENT);
10736 else set_errno(EVMSERR);
10740 devdsc.dsc$w_length = mynam.nam$b_dev;
10741 /* cast ok for read only parameter */
10742 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10744 retsts = sys$assign(&devdsc,&chan,0,0);
10745 if (!(retsts & 1)) {
10746 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10747 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10748 set_vaxc_errno(retsts);
10749 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
10750 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
10751 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
10752 else set_errno(EVMSERR);
10756 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10757 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10759 memset((void *) &myfib, 0, sizeof myfib);
10760 #if defined(__DECC) || defined(__DECCXX)
10761 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10762 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10763 /* This prevents the revision time of the file being reset to the current
10764 * time as a result of our IO$_MODIFY $QIO. */
10765 myfib.fib$l_acctl = FIB$M_NORECORD;
10767 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10768 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10769 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10771 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10772 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10773 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10774 _ckvmssts(sys$dassgn(chan));
10775 if (retsts & 1) retsts = iosb[0];
10776 if (!(retsts & 1)) {
10777 set_vaxc_errno(retsts);
10778 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10779 else set_errno(EVMSERR);
10785 #endif /* #if __CRTL_VER >= 70300000 */
10787 } /* end of my_utime() */
10791 * flex_stat, flex_lstat, flex_fstat
10792 * basic stat, but gets it right when asked to stat
10793 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10796 #ifndef _USE_STD_STAT
10797 /* encode_dev packs a VMS device name string into an integer to allow
10798 * simple comparisons. This can be used, for example, to check whether two
10799 * files are located on the same device, by comparing their encoded device
10800 * names. Even a string comparison would not do, because stat() reuses the
10801 * device name buffer for each call; so without encode_dev, it would be
10802 * necessary to save the buffer and use strcmp (this would mean a number of
10803 * changes to the standard Perl code, to say nothing of what a Perl script
10804 * would have to do.
10806 * The device lock id, if it exists, should be unique (unless perhaps compared
10807 * with lock ids transferred from other nodes). We have a lock id if the disk is
10808 * mounted cluster-wide, which is when we tend to get long (host-qualified)
10809 * device names. Thus we use the lock id in preference, and only if that isn't
10810 * available, do we try to pack the device name into an integer (flagged by
10811 * the sign bit (LOCKID_MASK) being set).
10813 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10814 * name and its encoded form, but it seems very unlikely that we will find
10815 * two files on different disks that share the same encoded device names,
10816 * and even more remote that they will share the same file id (if the test
10817 * is to check for the same file).
10819 * A better method might be to use sys$device_scan on the first call, and to
10820 * search for the device, returning an index into the cached array.
10821 * The number returned would be more intelligible.
10822 * This is probably not worth it, and anyway would take quite a bit longer
10823 * on the first call.
10825 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
10826 static mydev_t encode_dev (pTHX_ const char *dev)
10829 unsigned long int f;
10834 if (!dev || !dev[0]) return 0;
10838 struct dsc$descriptor_s dev_desc;
10839 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10841 /* For cluster-mounted disks, the disk lock identifier is unique, so we
10842 can try that first. */
10843 dev_desc.dsc$w_length = strlen (dev);
10844 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
10845 dev_desc.dsc$b_class = DSC$K_CLASS_S;
10846 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
10847 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10848 if (!$VMS_STATUS_SUCCESS(status)) {
10850 case SS$_NOSUCHDEV:
10851 SETERRNO(ENODEV, status);
10857 if (lockid) return (lockid & ~LOCKID_MASK);
10861 /* Otherwise we try to encode the device name */
10865 for (q = dev + strlen(dev); q--; q >= dev) {
10870 else if (isalpha (toupper (*q)))
10871 c= toupper (*q) - 'A' + (char)10;
10873 continue; /* Skip '$'s */
10875 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
10877 enc += f * (unsigned long int) c;
10879 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
10881 } /* end of encode_dev() */
10882 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10883 device_no = encode_dev(aTHX_ devname)
10885 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10886 device_no = new_dev_no
10890 is_null_device(name)
10893 if (decc_bug_devnull != 0) {
10894 if (strncmp("/dev/null", name, 9) == 0)
10897 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10898 The underscore prefix, controller letter, and unit number are
10899 independently optional; for our purposes, the colon punctuation
10900 is not. The colon can be trailed by optional directory and/or
10901 filename, but two consecutive colons indicates a nodename rather
10902 than a device. [pr] */
10903 if (*name == '_') ++name;
10904 if (tolower(*name++) != 'n') return 0;
10905 if (tolower(*name++) != 'l') return 0;
10906 if (tolower(*name) == 'a') ++name;
10907 if (*name == '0') ++name;
10908 return (*name++ == ':') && (*name != ':');
10913 Perl_cando_by_name_int
10914 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10916 static char usrname[L_cuserid];
10917 static struct dsc$descriptor_s usrdsc =
10918 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10919 char vmsname[NAM$C_MAXRSS+1];
10921 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10922 unsigned short int retlen, trnlnm_iter_count;
10923 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10924 union prvdef curprv;
10925 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10926 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10927 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10928 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10929 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10931 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10933 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10935 if (!fname || !*fname) return FALSE;
10936 /* Make sure we expand logical names, since sys$check_access doesn't */
10939 if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10940 fileified = PerlMem_malloc(VMS_MAXRSS);
10941 if (!strpbrk(fname,"/]>:")) {
10942 strcpy(fileified,fname);
10943 trnlnm_iter_count = 0;
10944 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10945 trnlnm_iter_count++;
10946 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10950 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10951 PerlMem_free(fileified);
10954 retlen = namdsc.dsc$w_length = strlen(vmsname);
10955 namdsc.dsc$a_pointer = vmsname;
10956 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10957 vmsname[retlen-1] == ':') {
10958 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10959 namdsc.dsc$w_length = strlen(fileified);
10960 namdsc.dsc$a_pointer = fileified;
10964 retlen = namdsc.dsc$w_length = strlen(fname);
10965 namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10969 case S_IXUSR: case S_IXGRP: case S_IXOTH:
10970 access = ARM$M_EXECUTE;
10971 flags = CHP$M_READ;
10973 case S_IRUSR: case S_IRGRP: case S_IROTH:
10974 access = ARM$M_READ;
10975 flags = CHP$M_READ | CHP$M_USEREADALL;
10977 case S_IWUSR: case S_IWGRP: case S_IWOTH:
10978 access = ARM$M_WRITE;
10979 flags = CHP$M_READ | CHP$M_WRITE;
10981 case S_IDUSR: case S_IDGRP: case S_IDOTH:
10982 access = ARM$M_DELETE;
10983 flags = CHP$M_READ | CHP$M_WRITE;
10986 if (fileified != NULL)
10987 PerlMem_free(fileified);
10991 /* Before we call $check_access, create a user profile with the current
10992 * process privs since otherwise it just uses the default privs from the
10993 * UAF and might give false positives or negatives. This only works on
10994 * VMS versions v6.0 and later since that's when sys$create_user_profile
10995 * became available.
10998 /* get current process privs and username */
10999 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11000 _ckvmssts(iosb[0]);
11002 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11004 /* find out the space required for the profile */
11005 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11006 &usrprodsc.dsc$w_length,0));
11008 /* allocate space for the profile and get it filled in */
11009 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11010 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11011 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11012 &usrprodsc.dsc$w_length,0));
11014 /* use the profile to check access to the file; free profile & analyze results */
11015 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
11016 PerlMem_free(usrprodsc.dsc$a_pointer);
11017 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11021 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11025 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
11026 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11027 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11028 set_vaxc_errno(retsts);
11029 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11030 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11031 else set_errno(ENOENT);
11032 if (fileified != NULL)
11033 PerlMem_free(fileified);
11036 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11037 if (fileified != NULL)
11038 PerlMem_free(fileified);
11043 if (fileified != NULL)
11044 PerlMem_free(fileified);
11045 return FALSE; /* Should never get here */
11049 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
11050 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11051 * subset of the applicable information.
11054 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11056 return cando_by_name_int
11057 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11058 } /* end of cando() */
11062 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11064 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11066 return cando_by_name_int(bit, effective, fname, 0);
11068 } /* end of cando_by_name() */
11072 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11074 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11076 if (!fstat(fd,(stat_t *) statbufp)) {
11078 char *vms_filename;
11079 vms_filename = PerlMem_malloc(VMS_MAXRSS);
11080 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11082 /* Save name for cando by name in VMS format */
11083 cptr = getname(fd, vms_filename, 1);
11085 /* This should not happen, but just in case */
11086 if (cptr == NULL) {
11087 statbufp->st_devnam[0] = 0;
11090 /* Make sure that the saved name fits in 255 characters */
11091 cptr = do_rmsexpand
11093 statbufp->st_devnam,
11096 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11100 statbufp->st_devnam[0] = 0;
11102 PerlMem_free(vms_filename);
11104 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11106 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11108 # ifdef RTL_USES_UTC
11109 # ifdef VMSISH_TIME
11111 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11112 statbufp->st_atime = _toloc(statbufp->st_atime);
11113 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11117 # ifdef VMSISH_TIME
11118 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11122 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11123 statbufp->st_atime = _toutc(statbufp->st_atime);
11124 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11131 } /* end of flex_fstat() */
11134 #if !defined(__VAX) && __CRTL_VER >= 80200000
11142 #define lstat(_x, _y) stat(_x, _y)
11145 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11148 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11150 char fileified[VMS_MAXRSS];
11151 char temp_fspec[VMS_MAXRSS];
11154 int saved_errno, saved_vaxc_errno;
11156 if (!fspec) return retval;
11157 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11158 strcpy(temp_fspec, fspec);
11160 if (decc_bug_devnull != 0) {
11161 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11162 memset(statbufp,0,sizeof *statbufp);
11163 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11164 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11165 statbufp->st_uid = 0x00010001;
11166 statbufp->st_gid = 0x0001;
11167 time((time_t *)&statbufp->st_mtime);
11168 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11173 /* Try for a directory name first. If fspec contains a filename without
11174 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11175 * and sea:[wine.dark]water. exist, we prefer the directory here.
11176 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11177 * not sea:[wine.dark]., if the latter exists. If the intended target is
11178 * the file with null type, specify this by calling flex_stat() with
11179 * a '.' at the end of fspec.
11181 * If we are in Posix filespec mode, accept the filename as is.
11183 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11184 if (decc_posix_compliant_pathnames == 0) {
11186 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11187 if (lstat_flag == 0)
11188 retval = stat(fileified,(stat_t *) statbufp);
11190 retval = lstat(fileified,(stat_t *) statbufp);
11191 save_spec = fileified;
11194 if (lstat_flag == 0)
11195 retval = stat(temp_fspec,(stat_t *) statbufp);
11197 retval = lstat(temp_fspec,(stat_t *) statbufp);
11198 save_spec = temp_fspec;
11200 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11202 if (lstat_flag == 0)
11203 retval = stat(temp_fspec,(stat_t *) statbufp);
11205 retval = lstat(temp_fspec,(stat_t *) statbufp);
11206 save_spec = temp_fspec;
11211 cptr = do_rmsexpand
11212 (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11214 statbufp->st_devnam[0] = 0;
11216 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11218 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11219 # ifdef RTL_USES_UTC
11220 # ifdef VMSISH_TIME
11222 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11223 statbufp->st_atime = _toloc(statbufp->st_atime);
11224 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11228 # ifdef VMSISH_TIME
11229 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11233 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11234 statbufp->st_atime = _toutc(statbufp->st_atime);
11235 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11239 /* If we were successful, leave errno where we found it */
11240 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11243 } /* end of flex_stat_int() */
11246 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11248 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11250 return flex_stat_int(fspec, statbufp, 0);
11254 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11256 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11258 return flex_stat_int(fspec, statbufp, 1);
11263 /*{{{char *my_getlogin()*/
11264 /* VMS cuserid == Unix getlogin, except calling sequence */
11268 static char user[L_cuserid];
11269 return cuserid(user);
11274 /* rmscopy - copy a file using VMS RMS routines
11276 * Copies contents and attributes of spec_in to spec_out, except owner
11277 * and protection information. Name and type of spec_in are used as
11278 * defaults for spec_out. The third parameter specifies whether rmscopy()
11279 * should try to propagate timestamps from the input file to the output file.
11280 * If it is less than 0, no timestamps are preserved. If it is 0, then
11281 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
11282 * propagated to the output file at creation iff the output file specification
11283 * did not contain an explicit name or type, and the revision date is always
11284 * updated at the end of the copy operation. If it is greater than 0, then
11285 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11286 * other than the revision date should be propagated, and bit 1 indicates
11287 * that the revision date should be propagated.
11289 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11291 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11292 * Incorporates, with permission, some code from EZCOPY by Tim Adye
11293 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
11294 * as part of the Perl standard distribution under the terms of the
11295 * GNU General Public License or the Perl Artistic License. Copies
11296 * of each may be found in the Perl standard distribution.
11298 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11300 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11302 char *vmsin, * vmsout, *esa, *esa_out,
11304 unsigned long int i, sts, sts2;
11306 struct FAB fab_in, fab_out;
11307 struct RAB rab_in, rab_out;
11308 rms_setup_nam(nam);
11309 rms_setup_nam(nam_out);
11310 struct XABDAT xabdat;
11311 struct XABFHC xabfhc;
11312 struct XABRDT xabrdt;
11313 struct XABSUM xabsum;
11315 vmsin = PerlMem_malloc(VMS_MAXRSS);
11316 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11317 vmsout = PerlMem_malloc(VMS_MAXRSS);
11318 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11319 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11320 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11321 PerlMem_free(vmsin);
11322 PerlMem_free(vmsout);
11323 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11327 esa = PerlMem_malloc(VMS_MAXRSS);
11328 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11329 fab_in = cc$rms_fab;
11330 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11331 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11332 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11333 fab_in.fab$l_fop = FAB$M_SQO;
11334 rms_bind_fab_nam(fab_in, nam);
11335 fab_in.fab$l_xab = (void *) &xabdat;
11337 rsa = PerlMem_malloc(VMS_MAXRSS);
11338 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11339 rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11340 rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11341 rms_nam_esl(nam) = 0;
11342 rms_nam_rsl(nam) = 0;
11343 rms_nam_esll(nam) = 0;
11344 rms_nam_rsll(nam) = 0;
11345 #ifdef NAM$M_NO_SHORT_UPCASE
11346 if (decc_efs_case_preserve)
11347 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11350 xabdat = cc$rms_xabdat; /* To get creation date */
11351 xabdat.xab$l_nxt = (void *) &xabfhc;
11353 xabfhc = cc$rms_xabfhc; /* To get record length */
11354 xabfhc.xab$l_nxt = (void *) &xabsum;
11356 xabsum = cc$rms_xabsum; /* To get key and area information */
11358 if (!((sts = sys$open(&fab_in)) & 1)) {
11359 PerlMem_free(vmsin);
11360 PerlMem_free(vmsout);
11363 set_vaxc_errno(sts);
11365 case RMS$_FNF: case RMS$_DNF:
11366 set_errno(ENOENT); break;
11368 set_errno(ENOTDIR); break;
11370 set_errno(ENODEV); break;
11372 set_errno(EINVAL); break;
11374 set_errno(EACCES); break;
11376 set_errno(EVMSERR);
11383 fab_out.fab$w_ifi = 0;
11384 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11385 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11386 fab_out.fab$l_fop = FAB$M_SQO;
11387 rms_bind_fab_nam(fab_out, nam_out);
11388 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11389 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11390 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11391 esa_out = PerlMem_malloc(VMS_MAXRSS);
11392 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11393 rms_set_rsa(nam_out, NULL, 0);
11394 rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11396 if (preserve_dates == 0) { /* Act like DCL COPY */
11397 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11398 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
11399 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11400 PerlMem_free(vmsin);
11401 PerlMem_free(vmsout);
11404 PerlMem_free(esa_out);
11405 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11406 set_vaxc_errno(sts);
11409 fab_out.fab$l_xab = (void *) &xabdat;
11410 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11411 preserve_dates = 1;
11413 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
11414 preserve_dates =0; /* bitmask from this point forward */
11416 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11417 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11418 PerlMem_free(vmsin);
11419 PerlMem_free(vmsout);
11422 PerlMem_free(esa_out);
11423 set_vaxc_errno(sts);
11426 set_errno(ENOENT); break;
11428 set_errno(ENOTDIR); break;
11430 set_errno(ENODEV); break;
11432 set_errno(EINVAL); break;
11434 set_errno(EACCES); break;
11436 set_errno(EVMSERR);
11440 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
11441 if (preserve_dates & 2) {
11442 /* sys$close() will process xabrdt, not xabdat */
11443 xabrdt = cc$rms_xabrdt;
11445 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11447 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11448 * is unsigned long[2], while DECC & VAXC use a struct */
11449 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11451 fab_out.fab$l_xab = (void *) &xabrdt;
11454 ubf = PerlMem_malloc(32256);
11455 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11456 rab_in = cc$rms_rab;
11457 rab_in.rab$l_fab = &fab_in;
11458 rab_in.rab$l_rop = RAB$M_BIO;
11459 rab_in.rab$l_ubf = ubf;
11460 rab_in.rab$w_usz = 32256;
11461 if (!((sts = sys$connect(&rab_in)) & 1)) {
11462 sys$close(&fab_in); sys$close(&fab_out);
11463 PerlMem_free(vmsin);
11464 PerlMem_free(vmsout);
11468 PerlMem_free(esa_out);
11469 set_errno(EVMSERR); set_vaxc_errno(sts);
11473 rab_out = cc$rms_rab;
11474 rab_out.rab$l_fab = &fab_out;
11475 rab_out.rab$l_rbf = ubf;
11476 if (!((sts = sys$connect(&rab_out)) & 1)) {
11477 sys$close(&fab_in); sys$close(&fab_out);
11478 PerlMem_free(vmsin);
11479 PerlMem_free(vmsout);
11483 PerlMem_free(esa_out);
11484 set_errno(EVMSERR); set_vaxc_errno(sts);
11488 while ((sts = sys$read(&rab_in))) { /* always true */
11489 if (sts == RMS$_EOF) break;
11490 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11491 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11492 sys$close(&fab_in); sys$close(&fab_out);
11493 PerlMem_free(vmsin);
11494 PerlMem_free(vmsout);
11498 PerlMem_free(esa_out);
11499 set_errno(EVMSERR); set_vaxc_errno(sts);
11505 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
11506 sys$close(&fab_in); sys$close(&fab_out);
11507 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11509 PerlMem_free(vmsin);
11510 PerlMem_free(vmsout);
11514 PerlMem_free(esa_out);
11515 set_errno(EVMSERR); set_vaxc_errno(sts);
11519 PerlMem_free(vmsin);
11520 PerlMem_free(vmsout);
11524 PerlMem_free(esa_out);
11527 } /* end of rmscopy() */
11531 /*** The following glue provides 'hooks' to make some of the routines
11532 * from this file available from Perl. These routines are sufficiently
11533 * basic, and are required sufficiently early in the build process,
11534 * that's it's nice to have them available to miniperl as well as the
11535 * full Perl, so they're set up here instead of in an extension. The
11536 * Perl code which handles importation of these names into a given
11537 * package lives in [.VMS]Filespec.pm in @INC.
11541 rmsexpand_fromperl(pTHX_ CV *cv)
11544 char *fspec, *defspec = NULL, *rslt;
11546 int fs_utf8, dfs_utf8;
11550 if (!items || items > 2)
11551 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11552 fspec = SvPV(ST(0),n_a);
11553 fs_utf8 = SvUTF8(ST(0));
11554 if (!fspec || !*fspec) XSRETURN_UNDEF;
11556 defspec = SvPV(ST(1),n_a);
11557 dfs_utf8 = SvUTF8(ST(1));
11559 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11560 ST(0) = sv_newmortal();
11561 if (rslt != NULL) {
11562 sv_usepvn(ST(0),rslt,strlen(rslt));
11571 vmsify_fromperl(pTHX_ CV *cv)
11578 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11579 utf8_fl = SvUTF8(ST(0));
11580 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11581 ST(0) = sv_newmortal();
11582 if (vmsified != NULL) {
11583 sv_usepvn(ST(0),vmsified,strlen(vmsified));
11592 unixify_fromperl(pTHX_ CV *cv)
11599 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11600 utf8_fl = SvUTF8(ST(0));
11601 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11602 ST(0) = sv_newmortal();
11603 if (unixified != NULL) {
11604 sv_usepvn(ST(0),unixified,strlen(unixified));
11613 fileify_fromperl(pTHX_ CV *cv)
11620 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11621 utf8_fl = SvUTF8(ST(0));
11622 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11623 ST(0) = sv_newmortal();
11624 if (fileified != NULL) {
11625 sv_usepvn(ST(0),fileified,strlen(fileified));
11634 pathify_fromperl(pTHX_ CV *cv)
11641 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11642 utf8_fl = SvUTF8(ST(0));
11643 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11644 ST(0) = sv_newmortal();
11645 if (pathified != NULL) {
11646 sv_usepvn(ST(0),pathified,strlen(pathified));
11655 vmspath_fromperl(pTHX_ CV *cv)
11662 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11663 utf8_fl = SvUTF8(ST(0));
11664 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11665 ST(0) = sv_newmortal();
11666 if (vmspath != NULL) {
11667 sv_usepvn(ST(0),vmspath,strlen(vmspath));
11676 unixpath_fromperl(pTHX_ CV *cv)
11683 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11684 utf8_fl = SvUTF8(ST(0));
11685 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11686 ST(0) = sv_newmortal();
11687 if (unixpath != NULL) {
11688 sv_usepvn(ST(0),unixpath,strlen(unixpath));
11697 candelete_fromperl(pTHX_ CV *cv)
11705 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11707 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11708 Newx(fspec, VMS_MAXRSS, char);
11709 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11710 if (SvTYPE(mysv) == SVt_PVGV) {
11711 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11712 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11720 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11721 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11728 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11734 rmscopy_fromperl(pTHX_ CV *cv)
11737 char *inspec, *outspec, *inp, *outp;
11739 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11740 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11741 unsigned long int sts;
11746 if (items < 2 || items > 3)
11747 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11749 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11750 Newx(inspec, VMS_MAXRSS, char);
11751 if (SvTYPE(mysv) == SVt_PVGV) {
11752 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11753 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11761 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11762 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11768 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11769 Newx(outspec, VMS_MAXRSS, char);
11770 if (SvTYPE(mysv) == SVt_PVGV) {
11771 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11772 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11781 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11782 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11789 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11791 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11797 /* The mod2fname is limited to shorter filenames by design, so it should
11798 * not be modified to support longer EFS pathnames
11801 mod2fname(pTHX_ CV *cv)
11804 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11805 workbuff[NAM$C_MAXRSS*1 + 1];
11806 int total_namelen = 3, counter, num_entries;
11807 /* ODS-5 ups this, but we want to be consistent, so... */
11808 int max_name_len = 39;
11809 AV *in_array = (AV *)SvRV(ST(0));
11811 num_entries = av_len(in_array);
11813 /* All the names start with PL_. */
11814 strcpy(ultimate_name, "PL_");
11816 /* Clean up our working buffer */
11817 Zero(work_name, sizeof(work_name), char);
11819 /* Run through the entries and build up a working name */
11820 for(counter = 0; counter <= num_entries; counter++) {
11821 /* If it's not the first name then tack on a __ */
11823 strcat(work_name, "__");
11825 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11829 /* Check to see if we actually have to bother...*/
11830 if (strlen(work_name) + 3 <= max_name_len) {
11831 strcat(ultimate_name, work_name);
11833 /* It's too darned big, so we need to go strip. We use the same */
11834 /* algorithm as xsubpp does. First, strip out doubled __ */
11835 char *source, *dest, last;
11838 for (source = work_name; *source; source++) {
11839 if (last == *source && last == '_') {
11845 /* Go put it back */
11846 strcpy(work_name, workbuff);
11847 /* Is it still too big? */
11848 if (strlen(work_name) + 3 > max_name_len) {
11849 /* Strip duplicate letters */
11852 for (source = work_name; *source; source++) {
11853 if (last == toupper(*source)) {
11857 last = toupper(*source);
11859 strcpy(work_name, workbuff);
11862 /* Is it *still* too big? */
11863 if (strlen(work_name) + 3 > max_name_len) {
11864 /* Too bad, we truncate */
11865 work_name[max_name_len - 2] = 0;
11867 strcat(ultimate_name, work_name);
11870 /* Okay, return it */
11871 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11876 hushexit_fromperl(pTHX_ CV *cv)
11881 VMSISH_HUSHED = SvTRUE(ST(0));
11883 ST(0) = boolSV(VMSISH_HUSHED);
11889 Perl_vms_start_glob
11890 (pTHX_ SV *tmpglob,
11894 struct vs_str_st *rslt;
11898 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11901 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11902 struct dsc$descriptor_vs rsdsc;
11903 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11904 unsigned long hasver = 0, isunix = 0;
11905 unsigned long int lff_flags = 0;
11908 #ifdef VMS_LONGNAME_SUPPORT
11909 lff_flags = LIB$M_FIL_LONG_NAMES;
11911 /* The Newx macro will not allow me to assign a smaller array
11912 * to the rslt pointer, so we will assign it to the begin char pointer
11913 * and then copy the value into the rslt pointer.
11915 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11916 rslt = (struct vs_str_st *)begin;
11918 rstr = &rslt->str[0];
11919 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11920 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11921 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11922 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11924 Newx(vmsspec, VMS_MAXRSS, char);
11926 /* We could find out if there's an explicit dev/dir or version
11927 by peeking into lib$find_file's internal context at
11928 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11929 but that's unsupported, so I don't want to do it now and
11930 have it bite someone in the future. */
11931 /* Fix-me: vms_split_path() is the only way to do this, the
11932 existing method will fail with many legal EFS or UNIX specifications
11935 cp = SvPV(tmpglob,i);
11938 if (cp[i] == ';') hasver = 1;
11939 if (cp[i] == '.') {
11940 if (sts) hasver = 1;
11943 if (cp[i] == '/') {
11944 hasdir = isunix = 1;
11947 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11952 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11955 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11956 if (!stat_sts && S_ISDIR(st.st_mode)) {
11957 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11958 ok = (wilddsc.dsc$a_pointer != NULL);
11961 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11962 ok = (wilddsc.dsc$a_pointer != NULL);
11965 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11967 /* If not extended character set, replace ? with % */
11968 /* With extended character set, ? is a wildcard single character */
11969 if (!decc_efs_case_preserve) {
11970 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11971 if (*cp == '?') *cp = '%';
11974 while (ok && $VMS_STATUS_SUCCESS(sts)) {
11975 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11976 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11978 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11979 &dfltdsc,NULL,&rms_sts,&lff_flags);
11980 if (!$VMS_STATUS_SUCCESS(sts))
11983 /* with varying string, 1st word of buffer contains result length */
11984 rstr[rslt->length] = '\0';
11986 /* Find where all the components are */
11987 v_sts = vms_split_path
12002 /* If no version on input, truncate the version on output */
12003 if (!hasver && (vs_len > 0)) {
12007 /* No version & a null extension on UNIX handling */
12008 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12014 if (!decc_efs_case_preserve) {
12015 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12019 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12023 /* Start with the name */
12026 strcat(begin,"\n");
12027 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12029 if (cxt) (void)lib$find_file_end(&cxt);
12030 if (ok && sts != RMS$_NMF &&
12031 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12034 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12036 PerlIO_close(tmpfp);
12040 PerlIO_rewind(tmpfp);
12041 IoTYPE(io) = IoTYPE_RDONLY;
12042 IoIFP(io) = fp = tmpfp;
12043 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
12054 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
12057 vms_realpath_fromperl(pTHX_ CV *cv)
12060 char *fspec, *rslt_spec, *rslt;
12063 if (!items || items != 1)
12064 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12066 fspec = SvPV(ST(0),n_a);
12067 if (!fspec || !*fspec) XSRETURN_UNDEF;
12069 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12070 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12071 ST(0) = sv_newmortal();
12073 sv_usepvn(ST(0),rslt,strlen(rslt));
12075 Safefree(rslt_spec);
12080 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12081 int do_vms_case_tolerant(void);
12084 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12087 ST(0) = boolSV(do_vms_case_tolerant());
12093 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12094 struct interp_intern *dst)
12096 memcpy(dst,src,sizeof(struct interp_intern));
12100 Perl_sys_intern_clear(pTHX)
12105 Perl_sys_intern_init(pTHX)
12107 unsigned int ix = RAND_MAX;
12112 /* fix me later to track running under GNV */
12113 /* this allows some limited testing */
12114 MY_POSIX_EXIT = decc_filename_unix_report;
12117 MY_INV_RAND_MAX = 1./x;
12121 init_os_extras(void)
12124 char* file = __FILE__;
12125 if (decc_disable_to_vms_logname_translation) {
12126 no_translate_barewords = TRUE;
12128 no_translate_barewords = FALSE;
12131 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12132 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12133 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12134 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12135 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12136 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12137 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12138 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12139 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12140 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12141 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12143 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12145 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12146 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12149 store_pipelocs(aTHX); /* will redo any earlier attempts */
12156 #if __CRTL_VER == 80200000
12157 /* This missed getting in to the DECC SDK for 8.2 */
12158 char *realpath(const char *file_name, char * resolved_name, ...);
12161 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12162 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12163 * The perl fallback routine to provide realpath() is not as efficient
12167 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12169 return realpath(filespec, outbuf);
12173 /* External entry points */
12174 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12175 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12177 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12182 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12183 /* case_tolerant */
12185 /*{{{int do_vms_case_tolerant(void)*/
12186 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12187 * controlled by a process setting.
12189 int do_vms_case_tolerant(void)
12191 return vms_process_case_tolerant;
12194 /* External entry points */
12195 int Perl_vms_case_tolerant(void)
12196 { return do_vms_case_tolerant(); }
12198 int Perl_vms_case_tolerant(void)
12199 { return vms_process_case_tolerant; }
12203 /* Start of DECC RTL Feature handling */
12205 static int sys_trnlnm
12206 (const char * logname,
12210 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12211 const unsigned long attr = LNM$M_CASE_BLIND;
12212 struct dsc$descriptor_s name_dsc;
12214 unsigned short result;
12215 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12218 name_dsc.dsc$w_length = strlen(logname);
12219 name_dsc.dsc$a_pointer = (char *)logname;
12220 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12221 name_dsc.dsc$b_class = DSC$K_CLASS_S;
12223 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12225 if ($VMS_STATUS_SUCCESS(status)) {
12227 /* Null terminate and return the string */
12228 /*--------------------------------------*/
12235 static int sys_crelnm
12236 (const char * logname,
12237 const char * value)
12240 const char * proc_table = "LNM$PROCESS_TABLE";
12241 struct dsc$descriptor_s proc_table_dsc;
12242 struct dsc$descriptor_s logname_dsc;
12243 struct itmlst_3 item_list[2];
12245 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12246 proc_table_dsc.dsc$w_length = strlen(proc_table);
12247 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12248 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12250 logname_dsc.dsc$a_pointer = (char *) logname;
12251 logname_dsc.dsc$w_length = strlen(logname);
12252 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12253 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12255 item_list[0].buflen = strlen(value);
12256 item_list[0].itmcode = LNM$_STRING;
12257 item_list[0].bufadr = (char *)value;
12258 item_list[0].retlen = NULL;
12260 item_list[1].buflen = 0;
12261 item_list[1].itmcode = 0;
12263 ret_val = sys$crelnm
12265 (const struct dsc$descriptor_s *)&proc_table_dsc,
12266 (const struct dsc$descriptor_s *)&logname_dsc,
12268 (const struct item_list_3 *) item_list);
12273 /* C RTL Feature settings */
12275 static int set_features
12276 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
12277 int (* cli_routine)(void), /* Not documented */
12278 void *image_info) /* Not documented */
12285 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12286 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12287 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12288 unsigned long case_perm;
12289 unsigned long case_image;
12292 /* Allow an exception to bring Perl into the VMS debugger */
12293 vms_debug_on_exception = 0;
12294 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12295 if ($VMS_STATUS_SUCCESS(status)) {
12296 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12297 vms_debug_on_exception = 1;
12299 vms_debug_on_exception = 0;
12302 /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12303 vms_vtf7_filenames = 0;
12304 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12305 if ($VMS_STATUS_SUCCESS(status)) {
12306 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12307 vms_vtf7_filenames = 1;
12309 vms_vtf7_filenames = 0;
12312 /* Dectect running under GNV Bash or other UNIX like shell */
12313 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12314 gnv_unix_shell = 0;
12315 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12316 if ($VMS_STATUS_SUCCESS(status)) {
12317 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12318 gnv_unix_shell = 1;
12319 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12320 set_feature_default("DECC$EFS_CHARSET", 1);
12321 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12322 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12323 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12324 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12327 gnv_unix_shell = 0;
12331 /* hacks to see if known bugs are still present for testing */
12333 /* Readdir is returning filenames in VMS syntax always */
12334 decc_bug_readdir_efs1 = 1;
12335 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12336 if ($VMS_STATUS_SUCCESS(status)) {
12337 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12338 decc_bug_readdir_efs1 = 1;
12340 decc_bug_readdir_efs1 = 0;
12343 /* PCP mode requires creating /dev/null special device file */
12344 decc_bug_devnull = 0;
12345 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12346 if ($VMS_STATUS_SUCCESS(status)) {
12347 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12348 decc_bug_devnull = 1;
12350 decc_bug_devnull = 0;
12353 /* fgetname returning a VMS name in UNIX mode */
12354 decc_bug_fgetname = 1;
12355 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12356 if ($VMS_STATUS_SUCCESS(status)) {
12357 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12358 decc_bug_fgetname = 1;
12360 decc_bug_fgetname = 0;
12363 /* UNIX directory names with no paths are broken in a lot of places */
12364 decc_dir_barename = 1;
12365 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12366 if ($VMS_STATUS_SUCCESS(status)) {
12367 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12368 decc_dir_barename = 1;
12370 decc_dir_barename = 0;
12373 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12374 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12376 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12377 if (decc_disable_to_vms_logname_translation < 0)
12378 decc_disable_to_vms_logname_translation = 0;
12381 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12383 decc_efs_case_preserve = decc$feature_get_value(s, 1);
12384 if (decc_efs_case_preserve < 0)
12385 decc_efs_case_preserve = 0;
12388 s = decc$feature_get_index("DECC$EFS_CHARSET");
12390 decc_efs_charset = decc$feature_get_value(s, 1);
12391 if (decc_efs_charset < 0)
12392 decc_efs_charset = 0;
12395 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12397 decc_filename_unix_report = decc$feature_get_value(s, 1);
12398 if (decc_filename_unix_report > 0)
12399 decc_filename_unix_report = 1;
12401 decc_filename_unix_report = 0;
12404 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12406 decc_filename_unix_only = decc$feature_get_value(s, 1);
12407 if (decc_filename_unix_only > 0) {
12408 decc_filename_unix_only = 1;
12411 decc_filename_unix_only = 0;
12415 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12417 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12418 if (decc_filename_unix_no_version < 0)
12419 decc_filename_unix_no_version = 0;
12422 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12424 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12425 if (decc_readdir_dropdotnotype < 0)
12426 decc_readdir_dropdotnotype = 0;
12429 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12430 if ($VMS_STATUS_SUCCESS(status)) {
12431 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12433 dflt = decc$feature_get_value(s, 4);
12435 decc_disable_posix_root = decc$feature_get_value(s, 1);
12436 if (decc_disable_posix_root <= 0) {
12437 decc$feature_set_value(s, 1, 1);
12438 decc_disable_posix_root = 1;
12442 /* Traditionally Perl assumes this is off */
12443 decc_disable_posix_root = 1;
12444 decc$feature_set_value(s, 1, 1);
12449 #if __CRTL_VER >= 80200000
12450 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12452 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12453 if (decc_posix_compliant_pathnames < 0)
12454 decc_posix_compliant_pathnames = 0;
12455 if (decc_posix_compliant_pathnames > 4)
12456 decc_posix_compliant_pathnames = 0;
12461 status = sys_trnlnm
12462 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12463 if ($VMS_STATUS_SUCCESS(status)) {
12464 val_str[0] = _toupper(val_str[0]);
12465 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12466 decc_disable_to_vms_logname_translation = 1;
12471 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12472 if ($VMS_STATUS_SUCCESS(status)) {
12473 val_str[0] = _toupper(val_str[0]);
12474 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12475 decc_efs_case_preserve = 1;
12480 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12481 if ($VMS_STATUS_SUCCESS(status)) {
12482 val_str[0] = _toupper(val_str[0]);
12483 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12484 decc_filename_unix_report = 1;
12487 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12488 if ($VMS_STATUS_SUCCESS(status)) {
12489 val_str[0] = _toupper(val_str[0]);
12490 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12491 decc_filename_unix_only = 1;
12492 decc_filename_unix_report = 1;
12495 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12496 if ($VMS_STATUS_SUCCESS(status)) {
12497 val_str[0] = _toupper(val_str[0]);
12498 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12499 decc_filename_unix_no_version = 1;
12502 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12503 if ($VMS_STATUS_SUCCESS(status)) {
12504 val_str[0] = _toupper(val_str[0]);
12505 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12506 decc_readdir_dropdotnotype = 1;
12511 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12513 /* Report true case tolerance */
12514 /*----------------------------*/
12515 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12516 if (!$VMS_STATUS_SUCCESS(status))
12517 case_perm = PPROP$K_CASE_BLIND;
12518 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12519 if (!$VMS_STATUS_SUCCESS(status))
12520 case_image = PPROP$K_CASE_BLIND;
12521 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12522 (case_image == PPROP$K_CASE_SENSITIVE))
12523 vms_process_case_tolerant = 0;
12528 /* CRTL can be initialized past this point, but not before. */
12529 /* DECC$CRTL_INIT(); */
12535 /* DECC dependent attributes */
12536 #if __DECC_VER < 60560002
12538 #define not_executable
12540 #define relative ,rel
12541 #define not_executable ,noexe
12544 #pragma extern_model save
12545 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12547 const __align (LONGWORD) int spare[8] = {0};
12548 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
12551 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
12552 nowrt,noshr relative not_executable
12554 const long vms_cc_features = (const long)set_features;
12557 ** Force a reference to LIB$INITIALIZE to ensure it
12558 ** exists in the image.
12560 int lib$initialize(void);
12562 #pragma extern_model strict_refdef
12564 int lib_init_ref = (int) lib$initialize;
12567 #pragma extern_model restore