3 * VMS-specific routines for perl5
6 * August 2005 Convert VMS status code to UNIX status codes
7 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
8 * and Perl_cando by Craig Berry
9 * 29-Aug-2000 Charles Lane's piping improvements rolled in
10 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
19 #include <climsgdef.h>
30 #include <libclidef.h>
32 #include <lib$routines.h>
35 #if __CRTL_VER >= 70301000 && !defined(__VAX)
45 #include <str$routines.h>
52 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
54 #define NO_EFN EFN$C_ENF
59 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
60 int decc$feature_get_index(const char *name);
61 char* decc$feature_get_name(int index);
62 int decc$feature_get_value(int index, int mode);
63 int decc$feature_set_value(int index, int mode, int value);
68 #pragma member_alignment save
69 #pragma nomember_alignment longword
74 unsigned short * retadr;
76 #pragma member_alignment restore
78 /* More specific prototype than in starlet_c.h makes programming errors
86 const struct dsc$descriptor_s * devnam,
87 const struct item_list_3 * itmlst,
89 void * (astadr)(unsigned long),
94 #if __CRTL_VER >= 70300000 && !defined(__VAX)
96 static int set_feature_default(const char *name, int value)
101 index = decc$feature_get_index(name);
103 status = decc$feature_set_value(index, 1, value);
104 if (index == -1 || (status == -1)) {
108 status = decc$feature_get_value(index, 1);
109 if (status != value) {
117 /* Older versions of ssdef.h don't have these */
118 #ifndef SS$_INVFILFOROP
119 # define SS$_INVFILFOROP 3930
121 #ifndef SS$_NOSUCHOBJECT
122 # define SS$_NOSUCHOBJECT 2696
125 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
126 #define PERLIO_NOT_STDIO 0
128 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
129 * code below needs to get to the underlying CRTL routines. */
130 #define DONT_MASK_RTL_CALLS
134 /* Anticipating future expansion in lexical warnings . . . */
135 #ifndef WARN_INTERNAL
136 # define WARN_INTERNAL WARN_MISC
139 #ifdef VMS_LONGNAME_SUPPORT
140 #include <libfildef.h>
143 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
144 # define RTL_USES_UTC 1
147 #ifdef USE_VMS_DECTERM
149 /* Routine to create a decterm for use with the Perl debugger */
150 /* No headers, this information was found in the Programming Concepts Manual */
153 (const struct dsc$descriptor_s * display,
154 const struct dsc$descriptor_s * setup_file,
155 const struct dsc$descriptor_s * customization,
156 struct dsc$descriptor_s * result_device_name,
157 unsigned short * result_device_name_length,
160 void * char_change_buffer);
163 /* gcc's header files don't #define direct access macros
164 * corresponding to VAXC's variant structs */
166 # define uic$v_format uic$r_uic_form.uic$v_format
167 # define uic$v_group uic$r_uic_form.uic$v_group
168 # define uic$v_member uic$r_uic_form.uic$v_member
169 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
170 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
171 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
172 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
175 #if defined(NEED_AN_H_ERRNO)
180 #pragma message disable pragma
181 #pragma member_alignment save
182 #pragma nomember_alignment longword
184 #pragma message disable misalgndmem
187 unsigned short int buflen;
188 unsigned short int itmcode;
190 unsigned short int *retlen;
193 struct filescan_itmlst_2 {
194 unsigned short length;
195 unsigned short itmcode;
200 unsigned short length;
205 #pragma message restore
206 #pragma member_alignment restore
209 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
210 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
211 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
212 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
213 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
214 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
215 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
216 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
217 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
218 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
219 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
221 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
222 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
223 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
224 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
226 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
227 #define PERL_LNM_MAX_ALLOWED_INDEX 127
229 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
230 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
233 #define PERL_LNM_MAX_ITER 10
235 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
236 #if __CRTL_VER >= 70302000 && !defined(__VAX)
237 #define MAX_DCL_SYMBOL (8192)
238 #define MAX_DCL_LINE_LENGTH (4096 - 4)
240 #define MAX_DCL_SYMBOL (1024)
241 #define MAX_DCL_LINE_LENGTH (1024 - 4)
244 static char *__mystrtolower(char *str)
246 if (str) for (; *str; ++str) *str= tolower(*str);
250 static struct dsc$descriptor_s fildevdsc =
251 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
252 static struct dsc$descriptor_s crtlenvdsc =
253 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
254 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
255 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
256 static struct dsc$descriptor_s **env_tables = defenv;
257 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
259 /* True if we shouldn't treat barewords as logicals during directory */
261 static int no_translate_barewords;
264 static int tz_updated = 1;
267 /* DECC Features that may need to affect how Perl interprets
268 * displays filename information
270 static int decc_disable_to_vms_logname_translation = 1;
271 static int decc_disable_posix_root = 1;
272 int decc_efs_case_preserve = 0;
273 static int decc_efs_charset = 0;
274 static int decc_filename_unix_no_version = 0;
275 static int decc_filename_unix_only = 0;
276 int decc_filename_unix_report = 0;
277 int decc_posix_compliant_pathnames = 0;
278 int decc_readdir_dropdotnotype = 0;
279 static int vms_process_case_tolerant = 1;
280 int vms_vtf7_filenames = 0;
281 int gnv_unix_shell = 0;
283 /* bug workarounds if needed */
284 int decc_bug_readdir_efs1 = 0;
285 int decc_bug_devnull = 1;
286 int decc_bug_fgetname = 0;
287 int decc_dir_barename = 0;
289 static int vms_debug_on_exception = 0;
291 /* Is this a UNIX file specification?
292 * No longer a simple check with EFS file specs
293 * For now, not a full check, but need to
294 * handle POSIX ^UP^ specifications
295 * Fixing to handle ^/ cases would require
296 * changes to many other conversion routines.
299 static int is_unix_filespec(const char *path)
305 if (strncmp(path,"\"^UP^",5) != 0) {
306 pch1 = strchr(path, '/');
311 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
312 if (decc_filename_unix_report || decc_filename_unix_only) {
313 if (strcmp(path,".") == 0)
321 /* This routine converts a UCS-2 character to be VTF-7 encoded.
324 static void ucs2_to_vtf7
326 unsigned long ucs2_char,
329 unsigned char * ucs_ptr;
332 ucs_ptr = (unsigned char *)&ucs2_char;
336 hex = (ucs_ptr[1] >> 4) & 0xf;
338 outspec[2] = hex + '0';
340 outspec[2] = (hex - 9) + 'A';
341 hex = ucs_ptr[1] & 0xF;
343 outspec[3] = hex + '0';
345 outspec[3] = (hex - 9) + 'A';
347 hex = (ucs_ptr[0] >> 4) & 0xf;
349 outspec[4] = hex + '0';
351 outspec[4] = (hex - 9) + 'A';
352 hex = ucs_ptr[1] & 0xF;
354 outspec[5] = hex + '0';
356 outspec[5] = (hex - 9) + 'A';
362 /* This handles the conversion of a UNIX extended character set to a ^
363 * escaped VMS character.
364 * in a UNIX file specification.
366 * The output count variable contains the number of characters added
367 * to the output string.
369 * The return value is the number of characters read from the input string
371 static int copy_expand_unix_filename_escape
372 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
380 utf8_flag = *utf8_fl;
384 if (*inspec >= 0x80) {
385 if (utf8_fl && vms_vtf7_filenames) {
386 unsigned long ucs_char;
390 if ((*inspec & 0xE0) == 0xC0) {
392 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
393 if (ucs_char >= 0x80) {
394 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
397 } else if ((*inspec & 0xF0) == 0xE0) {
399 ucs_char = ((inspec[0] & 0xF) << 12) +
400 ((inspec[1] & 0x3f) << 6) +
402 if (ucs_char >= 0x800) {
403 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
407 #if 0 /* I do not see longer sequences supported by OpenVMS */
408 /* Maybe some one can fix this later */
409 } else if ((*inspec & 0xF8) == 0xF0) {
412 } else if ((*inspec & 0xFC) == 0xF8) {
415 } else if ((*inspec & 0xFE) == 0xFC) {
422 /* High bit set, but not a unicode character! */
424 /* Non printing DECMCS or ISO Latin-1 character? */
425 if (*inspec <= 0x9F) {
429 hex = (*inspec >> 4) & 0xF;
431 outspec[1] = hex + '0';
433 outspec[1] = (hex - 9) + 'A';
437 outspec[2] = hex + '0';
439 outspec[2] = (hex - 9) + 'A';
443 } else if (*inspec == 0xA0) {
449 } else if (*inspec == 0xFF) {
461 /* Is this a macro that needs to be passed through?
462 * Macros start with $( and an alpha character, followed
463 * by a string of alpha numeric characters ending with a )
464 * If this does not match, then encode it as ODS-5.
466 if ((inspec[0] == '$') && (inspec[1] == '(')) {
469 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
471 outspec[0] = inspec[0];
472 outspec[1] = inspec[1];
473 outspec[2] = inspec[2];
475 while(isalnum(inspec[tcnt]) ||
476 (inspec[2] == '.') || (inspec[2] == '_')) {
477 outspec[tcnt] = inspec[tcnt];
480 if (inspec[tcnt] == ')') {
481 outspec[tcnt] = inspec[tcnt];
498 if (decc_efs_charset == 0)
525 /* Assume that this is to be escaped */
527 outspec[1] = *inspec;
531 case ' ': /* space */
532 /* Assume that this is to be escaped */
547 /* This handles the expansion of a '^' prefix to the proper character
548 * in a UNIX file specification.
550 * The output count variable contains the number of characters added
551 * to the output string.
553 * The return value is the number of characters read from the input
556 static int copy_expand_vms_filename_escape
557 (char *outspec, const char *inspec, int *output_cnt)
564 if (*inspec == '^') {
568 /* Non trailing dots should just be passed through */
573 case '_': /* space */
579 case 'U': /* Unicode - FIX-ME this is wrong. */
582 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
585 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
586 outspec[0] == c1 & 0xff;
587 outspec[1] == c2 & 0xff;
594 /* Error - do best we can to continue */
604 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
608 scnt = sscanf(inspec, "%2x", &c1);
609 outspec[0] = c1 & 0xff;
633 (const struct dsc$descriptor_s * srcstr,
634 struct filescan_itmlst_2 * valuelist,
635 unsigned long * fldflags,
636 struct dsc$descriptor_s *auxout,
637 unsigned short * retlen);
640 /* vms_split_path - Verify that the input file specification is a
641 * VMS format file specification, and provide pointers to the components of
642 * it. With EFS format filenames, this is virtually the only way to
643 * parse a VMS path specification into components.
645 * If the sum of the components do not add up to the length of the
646 * string, then the passed file specification is probably a UNIX style
649 static int vms_split_path
664 struct dsc$descriptor path_desc;
668 struct filescan_itmlst_2 item_list[9];
669 const int filespec = 0;
670 const int nodespec = 1;
671 const int devspec = 2;
672 const int rootspec = 3;
673 const int dirspec = 4;
674 const int namespec = 5;
675 const int typespec = 6;
676 const int verspec = 7;
678 /* Assume the worst for an easy exit */
693 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
694 path_desc.dsc$w_length = strlen(path);
695 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
696 path_desc.dsc$b_class = DSC$K_CLASS_S;
698 /* Get the total length, if it is shorter than the string passed
699 * then this was probably not a VMS formatted file specification
701 item_list[filespec].itmcode = FSCN$_FILESPEC;
702 item_list[filespec].length = 0;
703 item_list[filespec].component = NULL;
705 /* If the node is present, then it gets considered as part of the
706 * volume name to hopefully make things simple.
708 item_list[nodespec].itmcode = FSCN$_NODE;
709 item_list[nodespec].length = 0;
710 item_list[nodespec].component = NULL;
712 item_list[devspec].itmcode = FSCN$_DEVICE;
713 item_list[devspec].length = 0;
714 item_list[devspec].component = NULL;
716 /* root is a special case, adding it to either the directory or
717 * the device components will probalby complicate things for the
718 * callers of this routine, so leave it separate.
720 item_list[rootspec].itmcode = FSCN$_ROOT;
721 item_list[rootspec].length = 0;
722 item_list[rootspec].component = NULL;
724 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
725 item_list[dirspec].length = 0;
726 item_list[dirspec].component = NULL;
728 item_list[namespec].itmcode = FSCN$_NAME;
729 item_list[namespec].length = 0;
730 item_list[namespec].component = NULL;
732 item_list[typespec].itmcode = FSCN$_TYPE;
733 item_list[typespec].length = 0;
734 item_list[typespec].component = NULL;
736 item_list[verspec].itmcode = FSCN$_VERSION;
737 item_list[verspec].length = 0;
738 item_list[verspec].component = NULL;
740 item_list[8].itmcode = 0;
741 item_list[8].length = 0;
742 item_list[8].component = NULL;
744 status = sys$filescan
745 ((const struct dsc$descriptor_s *)&path_desc, item_list,
747 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
749 /* If we parsed it successfully these two lengths should be the same */
750 if (path_desc.dsc$w_length != item_list[filespec].length)
753 /* If we got here, then it is a VMS file specification */
756 /* set the volume name */
757 if (item_list[nodespec].length > 0) {
758 *volume = item_list[nodespec].component;
759 *vol_len = item_list[nodespec].length + item_list[devspec].length;
762 *volume = item_list[devspec].component;
763 *vol_len = item_list[devspec].length;
766 *root = item_list[rootspec].component;
767 *root_len = item_list[rootspec].length;
769 *dir = item_list[dirspec].component;
770 *dir_len = item_list[dirspec].length;
772 /* Now fun with versions and EFS file specifications
773 * The parser can not tell the difference when a "." is a version
774 * delimiter or a part of the file specification.
776 if ((decc_efs_charset) &&
777 (item_list[verspec].length > 0) &&
778 (item_list[verspec].component[0] == '.')) {
779 *name = item_list[namespec].component;
780 *name_len = item_list[namespec].length + item_list[typespec].length;
781 *ext = item_list[verspec].component;
782 *ext_len = item_list[verspec].length;
787 *name = item_list[namespec].component;
788 *name_len = item_list[namespec].length;
789 *ext = item_list[typespec].component;
790 *ext_len = item_list[typespec].length;
791 *version = item_list[verspec].component;
792 *ver_len = item_list[verspec].length;
799 * Routine to retrieve the maximum equivalence index for an input
800 * logical name. Some calls to this routine have no knowledge if
801 * the variable is a logical or not. So on error we return a max
804 /*{{{int my_maxidx(const char *lnm) */
806 my_maxidx(const char *lnm)
810 int attr = LNM$M_CASE_BLIND;
811 struct dsc$descriptor lnmdsc;
812 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
815 lnmdsc.dsc$w_length = strlen(lnm);
816 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
817 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
818 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
820 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
821 if ((status & 1) == 0)
828 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
830 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
831 struct dsc$descriptor_s **tabvec, unsigned long int flags)
834 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
835 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
836 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
838 unsigned char acmode;
839 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
840 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
841 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
842 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
844 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
845 #if defined(PERL_IMPLICIT_CONTEXT)
848 aTHX = PERL_GET_INTERP;
854 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
855 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
857 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
858 *cp2 = _toupper(*cp1);
859 if (cp1 - lnm > LNM$C_NAMLENGTH) {
860 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
864 lnmdsc.dsc$w_length = cp1 - lnm;
865 lnmdsc.dsc$a_pointer = uplnm;
866 uplnm[lnmdsc.dsc$w_length] = '\0';
867 secure = flags & PERL__TRNENV_SECURE;
868 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
869 if (!tabvec || !*tabvec) tabvec = env_tables;
871 for (curtab = 0; tabvec[curtab]; curtab++) {
872 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
873 if (!ivenv && !secure) {
878 Perl_warn(aTHX_ "Can't read CRTL environ\n");
881 retsts = SS$_NOLOGNAM;
882 for (i = 0; environ[i]; i++) {
883 if ((eq = strchr(environ[i],'=')) &&
884 lnmdsc.dsc$w_length == (eq - environ[i]) &&
885 !strncmp(environ[i],uplnm,eq - environ[i])) {
887 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
888 if (!eqvlen) continue;
893 if (retsts != SS$_NOLOGNAM) break;
896 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
897 !str$case_blind_compare(&tmpdsc,&clisym)) {
898 if (!ivsym && !secure) {
899 unsigned short int deflen = LNM$C_NAMLENGTH;
900 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
901 /* dynamic dsc to accomodate possible long value */
902 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
903 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
905 if (eqvlen > MAX_DCL_SYMBOL) {
906 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
907 eqvlen = MAX_DCL_SYMBOL;
908 /* Special hack--we might be called before the interpreter's */
909 /* fully initialized, in which case either thr or PL_curcop */
910 /* might be bogus. We have to check, since ckWARN needs them */
911 /* both to be valid if running threaded */
912 if (ckWARN(WARN_MISC)) {
913 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
916 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
918 _ckvmssts(lib$sfree1_dd(&eqvdsc));
919 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
920 if (retsts == LIB$_NOSUCHSYM) continue;
925 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
926 midx = my_maxidx(lnm);
927 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
928 lnmlst[1].bufadr = cp2;
930 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
931 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
932 if (retsts == SS$_NOLOGNAM) break;
933 /* PPFs have a prefix */
936 *((int *)uplnm) == *((int *)"SYS$") &&
938 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
939 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
940 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
941 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
942 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
943 memmove(eqv,eqv+4,eqvlen-4);
949 if ((retsts == SS$_IVLOGNAM) ||
950 (retsts == SS$_NOLOGNAM)) { continue; }
953 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
954 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
955 if (retsts == SS$_NOLOGNAM) continue;
958 eqvlen = strlen(eqv);
962 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
963 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
964 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
965 retsts == SS$_NOLOGNAM) {
966 set_errno(EINVAL); set_vaxc_errno(retsts);
968 else _ckvmssts(retsts);
970 } /* end of vmstrnenv */
973 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
974 /* Define as a function so we can access statics. */
975 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
977 return vmstrnenv(lnm,eqv,idx,fildev,
978 #ifdef SECURE_INTERNAL_GETENV
979 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
988 * Note: Uses Perl temp to store result so char * can be returned to
989 * caller; this pointer will be invalidated at next Perl statement
991 * We define this as a function rather than a macro in terms of my_getenv_len()
992 * so that it'll work when PL_curinterp is undefined (and we therefore can't
995 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
997 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1000 static char *__my_getenv_eqv = NULL;
1001 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1002 unsigned long int idx = 0;
1003 int trnsuccess, success, secure, saverr, savvmserr;
1007 midx = my_maxidx(lnm) + 1;
1009 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1010 /* Set up a temporary buffer for the return value; Perl will
1011 * clean it up at the next statement transition */
1012 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1013 if (!tmpsv) return NULL;
1017 /* Assume no interpreter ==> single thread */
1018 if (__my_getenv_eqv != NULL) {
1019 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1022 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1024 eqv = __my_getenv_eqv;
1027 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1028 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1030 getcwd(eqv,LNM$C_NAMLENGTH);
1034 /* Get rid of "000000/ in rooted filespecs */
1037 zeros = strstr(eqv, "/000000/");
1038 if (zeros != NULL) {
1040 mlen = len - (zeros - eqv) - 7;
1041 memmove(zeros, &zeros[7], mlen);
1049 /* Impose security constraints only if tainting */
1051 /* Impose security constraints only if tainting */
1052 secure = PL_curinterp ? PL_tainting : will_taint;
1053 saverr = errno; savvmserr = vaxc$errno;
1060 #ifdef SECURE_INTERNAL_GETENV
1061 secure ? PERL__TRNENV_SECURE : 0
1067 /* For the getenv interface we combine all the equivalence names
1068 * of a search list logical into one value to acquire a maximum
1069 * value length of 255*128 (assuming %ENV is using logicals).
1071 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1073 /* If the name contains a semicolon-delimited index, parse it
1074 * off and make sure we only retrieve the equivalence name for
1076 if ((cp2 = strchr(lnm,';')) != NULL) {
1078 uplnm[cp2-lnm] = '\0';
1079 idx = strtoul(cp2+1,NULL,0);
1081 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1084 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1086 /* Discard NOLOGNAM on internal calls since we're often looking
1087 * for an optional name, and this "error" often shows up as the
1088 * (bogus) exit status for a die() call later on. */
1089 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1090 return success ? eqv : Nullch;
1093 } /* end of my_getenv() */
1097 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1099 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1103 unsigned long idx = 0;
1105 static char *__my_getenv_len_eqv = NULL;
1106 int secure, saverr, savvmserr;
1109 midx = my_maxidx(lnm) + 1;
1111 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1112 /* Set up a temporary buffer for the return value; Perl will
1113 * clean it up at the next statement transition */
1114 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1115 if (!tmpsv) return NULL;
1119 /* Assume no interpreter ==> single thread */
1120 if (__my_getenv_len_eqv != NULL) {
1121 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1124 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1126 buf = __my_getenv_len_eqv;
1129 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1130 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1133 getcwd(buf,LNM$C_NAMLENGTH);
1136 /* Get rid of "000000/ in rooted filespecs */
1138 zeros = strstr(buf, "/000000/");
1139 if (zeros != NULL) {
1141 mlen = *len - (zeros - buf) - 7;
1142 memmove(zeros, &zeros[7], mlen);
1151 /* Impose security constraints only if tainting */
1152 secure = PL_curinterp ? PL_tainting : will_taint;
1153 saverr = errno; savvmserr = vaxc$errno;
1160 #ifdef SECURE_INTERNAL_GETENV
1161 secure ? PERL__TRNENV_SECURE : 0
1167 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1169 if ((cp2 = strchr(lnm,';')) != NULL) {
1171 buf[cp2-lnm] = '\0';
1172 idx = strtoul(cp2+1,NULL,0);
1174 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1177 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1179 /* Get rid of "000000/ in rooted filespecs */
1182 zeros = strstr(buf, "/000000/");
1183 if (zeros != NULL) {
1185 mlen = *len - (zeros - buf) - 7;
1186 memmove(zeros, &zeros[7], mlen);
1192 /* Discard NOLOGNAM on internal calls since we're often looking
1193 * for an optional name, and this "error" often shows up as the
1194 * (bogus) exit status for a die() call later on. */
1195 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1196 return *len ? buf : Nullch;
1199 } /* end of my_getenv_len() */
1202 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1204 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1206 /*{{{ void prime_env_iter() */
1208 prime_env_iter(void)
1209 /* Fill the %ENV associative array with all logical names we can
1210 * find, in preparation for iterating over it.
1213 static int primed = 0;
1214 HV *seenhv = NULL, *envhv;
1216 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1217 unsigned short int chan;
1218 #ifndef CLI$M_TRUSTED
1219 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1221 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1222 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1224 bool have_sym = FALSE, have_lnm = FALSE;
1225 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1226 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1227 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1228 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1229 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1230 #if defined(PERL_IMPLICIT_CONTEXT)
1233 #if defined(USE_ITHREADS)
1234 static perl_mutex primenv_mutex;
1235 MUTEX_INIT(&primenv_mutex);
1238 #if defined(PERL_IMPLICIT_CONTEXT)
1239 /* We jump through these hoops because we can be called at */
1240 /* platform-specific initialization time, which is before anything is */
1241 /* set up--we can't even do a plain dTHX since that relies on the */
1242 /* interpreter structure to be initialized */
1244 aTHX = PERL_GET_INTERP;
1250 if (primed || !PL_envgv) return;
1251 MUTEX_LOCK(&primenv_mutex);
1252 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1253 envhv = GvHVn(PL_envgv);
1254 /* Perform a dummy fetch as an lval to insure that the hash table is
1255 * set up. Otherwise, the hv_store() will turn into a nullop. */
1256 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1258 for (i = 0; env_tables[i]; i++) {
1259 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1260 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1261 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1263 if (have_sym || have_lnm) {
1264 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1265 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1266 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1267 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1270 for (i--; i >= 0; i--) {
1271 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1274 for (j = 0; environ[j]; j++) {
1275 if (!(start = strchr(environ[j],'='))) {
1276 if (ckWARN(WARN_INTERNAL))
1277 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1281 sv = newSVpv(start,0);
1283 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1288 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1289 !str$case_blind_compare(&tmpdsc,&clisym)) {
1290 strcpy(cmd,"Show Symbol/Global *");
1291 cmddsc.dsc$w_length = 20;
1292 if (env_tables[i]->dsc$w_length == 12 &&
1293 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1294 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1295 flags = defflags | CLI$M_NOLOGNAM;
1298 strcpy(cmd,"Show Logical *");
1299 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1300 strcat(cmd," /Table=");
1301 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1302 cmddsc.dsc$w_length = strlen(cmd);
1304 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1305 flags = defflags | CLI$M_NOCLISYM;
1308 /* Create a new subprocess to execute each command, to exclude the
1309 * remote possibility that someone could subvert a mbx or file used
1310 * to write multiple commands to a single subprocess.
1313 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1314 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1315 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1316 defflags &= ~CLI$M_TRUSTED;
1317 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1319 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1320 if (seenhv) SvREFCNT_dec(seenhv);
1323 char *cp1, *cp2, *key;
1324 unsigned long int sts, iosb[2], retlen, keylen;
1327 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1328 if (sts & 1) sts = iosb[0] & 0xffff;
1329 if (sts == SS$_ENDOFFILE) {
1331 while (substs == 0) { sys$hiber(); wakect++;}
1332 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1337 retlen = iosb[0] >> 16;
1338 if (!retlen) continue; /* blank line */
1340 if (iosb[1] != subpid) {
1342 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1346 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1347 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1349 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1350 if (*cp1 == '(' || /* Logical name table name */
1351 *cp1 == '=' /* Next eqv of searchlist */) continue;
1352 if (*cp1 == '"') cp1++;
1353 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1354 key = cp1; keylen = cp2 - cp1;
1355 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1356 while (*cp2 && *cp2 != '=') cp2++;
1357 while (*cp2 && *cp2 == '=') cp2++;
1358 while (*cp2 && *cp2 == ' ') cp2++;
1359 if (*cp2 == '"') { /* String translation; may embed "" */
1360 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1361 cp2++; cp1--; /* Skip "" surrounding translation */
1363 else { /* Numeric translation */
1364 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1365 cp1--; /* stop on last non-space char */
1367 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1368 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1371 PERL_HASH(hash,key,keylen);
1373 if (cp1 == cp2 && *cp2 == '.') {
1374 /* A single dot usually means an unprintable character, such as a null
1375 * to indicate a zero-length value. Get the actual value to make sure.
1377 char lnm[LNM$C_NAMLENGTH+1];
1378 char eqv[MAX_DCL_SYMBOL+1];
1380 strncpy(lnm, key, keylen);
1381 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1382 sv = newSVpvn(eqv, strlen(eqv));
1385 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1389 hv_store(envhv,key,keylen,sv,hash);
1390 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1392 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1393 /* get the PPFs for this process, not the subprocess */
1394 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1395 char eqv[LNM$C_NAMLENGTH+1];
1397 for (i = 0; ppfs[i]; i++) {
1398 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1399 sv = newSVpv(eqv,trnlen);
1401 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1406 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1407 if (buf) Safefree(buf);
1408 if (seenhv) SvREFCNT_dec(seenhv);
1409 MUTEX_UNLOCK(&primenv_mutex);
1412 } /* end of prime_env_iter */
1416 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1417 /* Define or delete an element in the same "environment" as
1418 * vmstrnenv(). If an element is to be deleted, it's removed from
1419 * the first place it's found. If it's to be set, it's set in the
1420 * place designated by the first element of the table vector.
1421 * Like setenv() returns 0 for success, non-zero on error.
1424 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1427 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1428 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1430 unsigned long int retsts, usermode = PSL$C_USER;
1431 struct itmlst_3 *ile, *ilist;
1432 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1433 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1434 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1435 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1436 $DESCRIPTOR(local,"_LOCAL");
1439 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1440 return SS$_IVLOGNAM;
1443 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1444 *cp2 = _toupper(*cp1);
1445 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1446 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1447 return SS$_IVLOGNAM;
1450 lnmdsc.dsc$w_length = cp1 - lnm;
1451 if (!tabvec || !*tabvec) tabvec = env_tables;
1453 if (!eqv) { /* we're deleting n element */
1454 for (curtab = 0; tabvec[curtab]; curtab++) {
1455 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1457 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1458 if ((cp1 = strchr(environ[i],'=')) &&
1459 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1460 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1462 return setenv(lnm,"",1) ? vaxc$errno : 0;
1465 ivenv = 1; retsts = SS$_NOLOGNAM;
1467 if (ckWARN(WARN_INTERNAL))
1468 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1469 ivenv = 1; retsts = SS$_NOSUCHPGM;
1475 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1476 !str$case_blind_compare(&tmpdsc,&clisym)) {
1477 unsigned int symtype;
1478 if (tabvec[curtab]->dsc$w_length == 12 &&
1479 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1480 !str$case_blind_compare(&tmpdsc,&local))
1481 symtype = LIB$K_CLI_LOCAL_SYM;
1482 else symtype = LIB$K_CLI_GLOBAL_SYM;
1483 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1484 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1485 if (retsts == LIB$_NOSUCHSYM) continue;
1489 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1490 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1491 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1492 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1493 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1497 else { /* we're defining a value */
1498 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1500 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1502 if (ckWARN(WARN_INTERNAL))
1503 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1504 retsts = SS$_NOSUCHPGM;
1508 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1509 eqvdsc.dsc$w_length = strlen(eqv);
1510 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1511 !str$case_blind_compare(&tmpdsc,&clisym)) {
1512 unsigned int symtype;
1513 if (tabvec[0]->dsc$w_length == 12 &&
1514 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1515 !str$case_blind_compare(&tmpdsc,&local))
1516 symtype = LIB$K_CLI_LOCAL_SYM;
1517 else symtype = LIB$K_CLI_GLOBAL_SYM;
1518 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1521 if (!*eqv) eqvdsc.dsc$w_length = 1;
1522 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1524 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1525 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1526 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1527 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1528 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1529 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1532 Newx(ilist,nseg+1,struct itmlst_3);
1535 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1538 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1540 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1541 ile->itmcode = LNM$_STRING;
1543 if ((j+1) == nseg) {
1544 ile->buflen = strlen(c);
1545 /* in case we are truncating one that's too long */
1546 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1549 ile->buflen = LNM$C_NAMLENGTH;
1553 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1557 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1562 if (!(retsts & 1)) {
1564 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1565 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1566 set_errno(EVMSERR); break;
1567 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1568 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1569 set_errno(EINVAL); break;
1571 set_errno(EACCES); break;
1576 set_vaxc_errno(retsts);
1577 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1580 /* We reset error values on success because Perl does an hv_fetch()
1581 * before each hv_store(), and if the thing we're setting didn't
1582 * previously exist, we've got a leftover error message. (Of course,
1583 * this fails in the face of
1584 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1585 * in that the error reported in $! isn't spurious,
1586 * but it's right more often than not.)
1588 set_errno(0); set_vaxc_errno(retsts);
1592 } /* end of vmssetenv() */
1595 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1596 /* This has to be a function since there's a prototype for it in proto.h */
1598 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1601 int len = strlen(lnm);
1605 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1606 if (!strcmp(uplnm,"DEFAULT")) {
1607 if (eqv && *eqv) my_chdir(eqv);
1611 #ifndef RTL_USES_UTC
1612 if (len == 6 || len == 2) {
1615 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1617 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1618 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1622 (void) vmssetenv(lnm,eqv,NULL);
1626 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1628 * sets a user-mode logical in the process logical name table
1629 * used for redirection of sys$error
1632 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1634 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1635 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1636 unsigned long int iss, attr = LNM$M_CONFINE;
1637 unsigned char acmode = PSL$C_USER;
1638 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1640 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1641 d_name.dsc$w_length = strlen(name);
1643 lnmlst[0].buflen = strlen(eqv);
1644 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1646 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1647 if (!(iss&1)) lib$signal(iss);
1652 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1653 /* my_crypt - VMS password hashing
1654 * my_crypt() provides an interface compatible with the Unix crypt()
1655 * C library function, and uses sys$hash_password() to perform VMS
1656 * password hashing. The quadword hashed password value is returned
1657 * as a NUL-terminated 8 character string. my_crypt() does not change
1658 * the case of its string arguments; in order to match the behavior
1659 * of LOGINOUT et al., alphabetic characters in both arguments must
1660 * be upcased by the caller.
1662 * - fix me to call ACM services when available
1665 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1667 # ifndef UAI$C_PREFERRED_ALGORITHM
1668 # define UAI$C_PREFERRED_ALGORITHM 127
1670 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1671 unsigned short int salt = 0;
1672 unsigned long int sts;
1674 unsigned short int dsc$w_length;
1675 unsigned char dsc$b_type;
1676 unsigned char dsc$b_class;
1677 const char * dsc$a_pointer;
1678 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1679 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1680 struct itmlst_3 uailst[3] = {
1681 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1682 { sizeof salt, UAI$_SALT, &salt, 0},
1683 { 0, 0, NULL, NULL}};
1684 static char hash[9];
1686 usrdsc.dsc$w_length = strlen(usrname);
1687 usrdsc.dsc$a_pointer = usrname;
1688 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1690 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1694 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1699 set_vaxc_errno(sts);
1700 if (sts != RMS$_RNF) return NULL;
1703 txtdsc.dsc$w_length = strlen(textpasswd);
1704 txtdsc.dsc$a_pointer = textpasswd;
1705 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1706 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1709 return (char *) hash;
1711 } /* end of my_crypt() */
1715 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1716 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1717 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1719 /* fixup barenames that are directories for internal use.
1720 * There have been problems with the consistent handling of UNIX
1721 * style directory names when routines are presented with a name that
1722 * has no directory delimitors at all. So this routine will eventually
1725 static char * fixup_bare_dirnames(const char * name)
1727 if (decc_disable_to_vms_logname_translation) {
1734 * A little hack to get around a bug in some implemenation of remove()
1735 * that do not know how to delete a directory
1737 * Delete any file to which user has control access, regardless of whether
1738 * delete access is explicitly allowed.
1739 * Limitations: User must have write access to parent directory.
1740 * Does not block signals or ASTs; if interrupted in midstream
1741 * may leave file with an altered ACL.
1744 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1746 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1748 char *vmsname, *rspec;
1750 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1751 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1752 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1754 unsigned char myace$b_length;
1755 unsigned char myace$b_type;
1756 unsigned short int myace$w_flags;
1757 unsigned long int myace$l_access;
1758 unsigned long int myace$l_ident;
1759 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1760 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1761 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1763 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1764 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1765 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1766 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1767 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1768 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1770 /* Expand the input spec using RMS, since the CRTL remove() and
1771 * system services won't do this by themselves, so we may miss
1772 * a file "hiding" behind a logical name or search list. */
1773 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1774 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1776 if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1777 PerlMem_free(vmsname);
1781 if (decc_posix_compliant_pathnames) {
1782 /* In POSIX mode, we prefer to remove the UNIX name */
1784 remove_name = (char *)name;
1787 rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1788 if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1789 if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1790 PerlMem_free(rspec);
1791 PerlMem_free(vmsname);
1794 PerlMem_free(vmsname);
1795 remove_name = rspec;
1798 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1800 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1801 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1802 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1804 do_pathify_dirspec(name, remove_name, 0, NULL);
1805 if (!rmdir(remove_name)) {
1807 PerlMem_free(remove_name);
1808 PerlMem_free(rspec);
1809 return 0; /* Can we just get rid of it? */
1813 if (!rmdir(remove_name)) {
1814 PerlMem_free(rspec);
1815 return 0; /* Can we just get rid of it? */
1821 if (!remove(remove_name)) {
1822 PerlMem_free(rspec);
1823 return 0; /* Can we just get rid of it? */
1826 /* If not, can changing protections help? */
1827 if (vaxc$errno != RMS$_PRV) {
1828 PerlMem_free(rspec);
1832 /* No, so we get our own UIC to use as a rights identifier,
1833 * and the insert an ACE at the head of the ACL which allows us
1834 * to delete the file.
1836 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1837 fildsc.dsc$w_length = strlen(rspec);
1838 fildsc.dsc$a_pointer = rspec;
1840 newace.myace$l_ident = oldace.myace$l_ident;
1841 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1843 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1844 set_errno(ENOENT); break;
1846 set_errno(ENOTDIR); break;
1848 set_errno(ENODEV); break;
1849 case RMS$_SYN: case SS$_INVFILFOROP:
1850 set_errno(EINVAL); break;
1852 set_errno(EACCES); break;
1856 set_vaxc_errno(aclsts);
1857 PerlMem_free(rspec);
1860 /* Grab any existing ACEs with this identifier in case we fail */
1861 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1862 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1863 || fndsts == SS$_NOMOREACE ) {
1864 /* Add the new ACE . . . */
1865 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1868 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1870 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1871 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1872 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1874 do_pathify_dirspec(name, remove_name, 0, NULL);
1875 rmsts = rmdir(remove_name);
1876 PerlMem_free(remove_name);
1879 rmsts = rmdir(remove_name);
1883 rmsts = remove(remove_name);
1885 /* We blew it - dir with files in it, no write priv for
1886 * parent directory, etc. Put things back the way they were. */
1887 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1890 addlst[0].bufadr = &oldace;
1891 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1898 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1899 /* We just deleted it, so of course it's not there. Some versions of
1900 * VMS seem to return success on the unlock operation anyhow (after all
1901 * the unlock is successful), but others don't.
1903 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1904 if (aclsts & 1) aclsts = fndsts;
1905 if (!(aclsts & 1)) {
1907 set_vaxc_errno(aclsts);
1908 PerlMem_free(rspec);
1912 PerlMem_free(rspec);
1915 } /* end of kill_file() */
1919 /*{{{int do_rmdir(char *name)*/
1921 Perl_do_rmdir(pTHX_ const char *name)
1923 char dirfile[NAM$C_MAXRSS+1];
1927 if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1928 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1929 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1932 } /* end of do_rmdir */
1936 * Delete any file to which user has control access, regardless of whether
1937 * delete access is explicitly allowed.
1938 * Limitations: User must have write access to parent directory.
1939 * Does not block signals or ASTs; if interrupted in midstream
1940 * may leave file with an altered ACL.
1943 /*{{{int kill_file(char *name)*/
1945 Perl_kill_file(pTHX_ const char *name)
1947 char rspec[NAM$C_MAXRSS+1];
1949 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1950 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1951 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1953 unsigned char myace$b_length;
1954 unsigned char myace$b_type;
1955 unsigned short int myace$w_flags;
1956 unsigned long int myace$l_access;
1957 unsigned long int myace$l_ident;
1958 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1959 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1960 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1962 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1963 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1964 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1965 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1966 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1967 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1969 /* Expand the input spec using RMS, since the CRTL remove() and
1970 * system services won't do this by themselves, so we may miss
1971 * a file "hiding" behind a logical name or search list. */
1972 tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1973 if (tspec == NULL) return -1;
1974 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1975 /* If not, can changing protections help? */
1976 if (vaxc$errno != RMS$_PRV) return -1;
1978 /* No, so we get our own UIC to use as a rights identifier,
1979 * and the insert an ACE at the head of the ACL which allows us
1980 * to delete the file.
1982 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1983 fildsc.dsc$w_length = strlen(rspec);
1984 fildsc.dsc$a_pointer = rspec;
1986 newace.myace$l_ident = oldace.myace$l_ident;
1987 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1989 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1990 set_errno(ENOENT); break;
1992 set_errno(ENOTDIR); break;
1994 set_errno(ENODEV); break;
1995 case RMS$_SYN: case SS$_INVFILFOROP:
1996 set_errno(EINVAL); break;
1998 set_errno(EACCES); break;
2002 set_vaxc_errno(aclsts);
2005 /* Grab any existing ACEs with this identifier in case we fail */
2006 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2007 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2008 || fndsts == SS$_NOMOREACE ) {
2009 /* Add the new ACE . . . */
2010 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2012 if ((rmsts = remove(name))) {
2013 /* We blew it - dir with files in it, no write priv for
2014 * parent directory, etc. Put things back the way they were. */
2015 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2018 addlst[0].bufadr = &oldace;
2019 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2026 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2027 /* We just deleted it, so of course it's not there. Some versions of
2028 * VMS seem to return success on the unlock operation anyhow (after all
2029 * the unlock is successful), but others don't.
2031 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2032 if (aclsts & 1) aclsts = fndsts;
2033 if (!(aclsts & 1)) {
2035 set_vaxc_errno(aclsts);
2041 } /* end of kill_file() */
2045 /*{{{int my_mkdir(char *,Mode_t)*/
2047 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2049 STRLEN dirlen = strlen(dir);
2051 /* zero length string sometimes gives ACCVIO */
2052 if (dirlen == 0) return -1;
2054 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2055 * null file name/type. However, it's commonplace under Unix,
2056 * so we'll allow it for a gain in portability.
2058 if (dir[dirlen-1] == '/') {
2059 char *newdir = savepvn(dir,dirlen-1);
2060 int ret = mkdir(newdir,mode);
2064 else return mkdir(dir,mode);
2065 } /* end of my_mkdir */
2068 /*{{{int my_chdir(char *)*/
2070 Perl_my_chdir(pTHX_ const char *dir)
2072 STRLEN dirlen = strlen(dir);
2074 /* zero length string sometimes gives ACCVIO */
2075 if (dirlen == 0) return -1;
2078 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2079 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2080 * so that existing scripts do not need to be changed.
2083 while ((dirlen > 0) && (*dir1 == ' ')) {
2088 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2090 * null file name/type. However, it's commonplace under Unix,
2091 * so we'll allow it for a gain in portability.
2093 * - Preview- '/' will be valid soon on VMS
2095 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2096 char *newdir = savepvn(dir1,dirlen-1);
2097 int ret = chdir(newdir);
2101 else return chdir(dir1);
2102 } /* end of my_chdir */
2106 /*{{{FILE *my_tmpfile()*/
2113 if ((fp = tmpfile())) return fp;
2115 cp = PerlMem_malloc(L_tmpnam+24);
2116 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2118 if (decc_filename_unix_only == 0)
2119 strcpy(cp,"Sys$Scratch:");
2122 tmpnam(cp+strlen(cp));
2123 strcat(cp,".Perltmp");
2124 fp = fopen(cp,"w+","fop=dlt");
2131 #ifndef HOMEGROWN_POSIX_SIGNALS
2133 * The C RTL's sigaction fails to check for invalid signal numbers so we
2134 * help it out a bit. The docs are correct, but the actual routine doesn't
2135 * do what the docs say it will.
2137 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2139 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2140 struct sigaction* oact)
2142 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2143 SETERRNO(EINVAL, SS$_INVARG);
2146 return sigaction(sig, act, oact);
2151 #ifdef KILL_BY_SIGPRC
2152 #include <errnodef.h>
2154 /* We implement our own kill() using the undocumented system service
2155 sys$sigprc for one of two reasons:
2157 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2158 target process to do a sys$exit, which usually can't be handled
2159 gracefully...certainly not by Perl and the %SIG{} mechanism.
2161 2.) If the kill() in the CRTL can't be called from a signal
2162 handler without disappearing into the ether, i.e., the signal
2163 it purportedly sends is never trapped. Still true as of VMS 7.3.
2165 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2166 in the target process rather than calling sys$exit.
2168 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2169 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2170 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2171 with condition codes C$_SIG0+nsig*8, catching the exception on the
2172 target process and resignaling with appropriate arguments.
2174 But we don't have that VMS 7.0+ exception handler, so if you
2175 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2177 Also note that SIGTERM is listed in the docs as being "unimplemented",
2178 yet always seems to be signaled with a VMS condition code of 4 (and
2179 correctly handled for that code). So we hardwire it in.
2181 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2182 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2183 than signalling with an unrecognized (and unhandled by CRTL) code.
2186 #define _MY_SIG_MAX 28
2189 Perl_sig_to_vmscondition_int(int sig)
2191 static unsigned int sig_code[_MY_SIG_MAX+1] =
2194 SS$_HANGUP, /* 1 SIGHUP */
2195 SS$_CONTROLC, /* 2 SIGINT */
2196 SS$_CONTROLY, /* 3 SIGQUIT */
2197 SS$_RADRMOD, /* 4 SIGILL */
2198 SS$_BREAK, /* 5 SIGTRAP */
2199 SS$_OPCCUS, /* 6 SIGABRT */
2200 SS$_COMPAT, /* 7 SIGEMT */
2202 SS$_FLTOVF, /* 8 SIGFPE VAX */
2204 SS$_HPARITH, /* 8 SIGFPE AXP */
2206 SS$_ABORT, /* 9 SIGKILL */
2207 SS$_ACCVIO, /* 10 SIGBUS */
2208 SS$_ACCVIO, /* 11 SIGSEGV */
2209 SS$_BADPARAM, /* 12 SIGSYS */
2210 SS$_NOMBX, /* 13 SIGPIPE */
2211 SS$_ASTFLT, /* 14 SIGALRM */
2228 #if __VMS_VER >= 60200000
2229 static int initted = 0;
2232 sig_code[16] = C$_SIGUSR1;
2233 sig_code[17] = C$_SIGUSR2;
2234 #if __CRTL_VER >= 70000000
2235 sig_code[20] = C$_SIGCHLD;
2237 #if __CRTL_VER >= 70300000
2238 sig_code[28] = C$_SIGWINCH;
2243 if (sig < _SIG_MIN) return 0;
2244 if (sig > _MY_SIG_MAX) return 0;
2245 return sig_code[sig];
2249 Perl_sig_to_vmscondition(int sig)
2252 if (vms_debug_on_exception != 0)
2253 lib$signal(SS$_DEBUG);
2255 return Perl_sig_to_vmscondition_int(sig);
2260 Perl_my_kill(int pid, int sig)
2265 int sys$sigprc(unsigned int *pidadr,
2266 struct dsc$descriptor_s *prcname,
2269 /* sig 0 means validate the PID */
2270 /*------------------------------*/
2272 const unsigned long int jpicode = JPI$_PID;
2275 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2276 if ($VMS_STATUS_SUCCESS(status))
2279 case SS$_NOSUCHNODE:
2280 case SS$_UNREACHABLE:
2294 code = Perl_sig_to_vmscondition_int(sig);
2297 SETERRNO(EINVAL, SS$_BADPARAM);
2301 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2302 * signals are to be sent to multiple processes.
2303 * pid = 0 - all processes in group except ones that the system exempts
2304 * pid = -1 - all processes except ones that the system exempts
2305 * pid = -n - all processes in group (abs(n)) except ...
2306 * For now, just report as not supported.
2310 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2314 iss = sys$sigprc((unsigned int *)&pid,0,code);
2315 if (iss&1) return 0;
2319 set_errno(EPERM); break;
2321 case SS$_NOSUCHNODE:
2322 case SS$_UNREACHABLE:
2323 set_errno(ESRCH); break;
2325 set_errno(ENOMEM); break;
2330 set_vaxc_errno(iss);
2336 /* Routine to convert a VMS status code to a UNIX status code.
2337 ** More tricky than it appears because of conflicting conventions with
2340 ** VMS status codes are a bit mask, with the least significant bit set for
2343 ** Special UNIX status of EVMSERR indicates that no translation is currently
2344 ** available, and programs should check the VMS status code.
2346 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2350 #ifndef C_FACILITY_NO
2351 #define C_FACILITY_NO 0x350000
2354 #define DCL_IVVERB 0x38090
2357 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2365 /* Assume the best or the worst */
2366 if (vms_status & STS$M_SUCCESS)
2369 unix_status = EVMSERR;
2371 msg_status = vms_status & ~STS$M_CONTROL;
2373 facility = vms_status & STS$M_FAC_NO;
2374 fac_sp = vms_status & STS$M_FAC_SP;
2375 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2377 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2383 unix_status = EFAULT;
2385 case SS$_DEVOFFLINE:
2386 unix_status = EBUSY;
2389 unix_status = ENOTCONN;
2397 case SS$_INVFILFOROP:
2401 unix_status = EINVAL;
2403 case SS$_UNSUPPORTED:
2404 unix_status = ENOTSUP;
2409 unix_status = EACCES;
2411 case SS$_DEVICEFULL:
2412 unix_status = ENOSPC;
2415 unix_status = ENODEV;
2417 case SS$_NOSUCHFILE:
2418 case SS$_NOSUCHOBJECT:
2419 unix_status = ENOENT;
2421 case SS$_ABORT: /* Fatal case */
2422 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2423 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2424 unix_status = EINTR;
2427 unix_status = E2BIG;
2430 unix_status = ENOMEM;
2433 unix_status = EPERM;
2435 case SS$_NOSUCHNODE:
2436 case SS$_UNREACHABLE:
2437 unix_status = ESRCH;
2440 unix_status = ECHILD;
2443 if ((facility == 0) && (msg_no < 8)) {
2444 /* These are not real VMS status codes so assume that they are
2445 ** already UNIX status codes
2447 unix_status = msg_no;
2453 /* Translate a POSIX exit code to a UNIX exit code */
2454 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2455 unix_status = (msg_no & 0x07F8) >> 3;
2459 /* Documented traditional behavior for handling VMS child exits */
2460 /*--------------------------------------------------------------*/
2461 if (child_flag != 0) {
2463 /* Success / Informational return 0 */
2464 /*----------------------------------*/
2465 if (msg_no & STS$K_SUCCESS)
2468 /* Warning returns 1 */
2469 /*-------------------*/
2470 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2473 /* Everything else pass through the severity bits */
2474 /*------------------------------------------------*/
2475 return (msg_no & STS$M_SEVERITY);
2478 /* Normal VMS status to ERRNO mapping attempt */
2479 /*--------------------------------------------*/
2480 switch(msg_status) {
2481 /* case RMS$_EOF: */ /* End of File */
2482 case RMS$_FNF: /* File Not Found */
2483 case RMS$_DNF: /* Dir Not Found */
2484 unix_status = ENOENT;
2486 case RMS$_RNF: /* Record Not Found */
2487 unix_status = ESRCH;
2490 unix_status = ENOTDIR;
2493 unix_status = ENODEV;
2498 unix_status = EBADF;
2501 unix_status = EEXIST;
2505 case LIB$_INVSTRDES:
2507 case LIB$_NOSUCHSYM:
2508 case LIB$_INVSYMNAM:
2510 unix_status = EINVAL;
2516 unix_status = E2BIG;
2518 case RMS$_PRV: /* No privilege */
2519 case RMS$_ACC: /* ACP file access failed */
2520 case RMS$_WLK: /* Device write locked */
2521 unix_status = EACCES;
2523 /* case RMS$_NMF: */ /* No more files */
2531 /* Try to guess at what VMS error status should go with a UNIX errno
2532 * value. This is hard to do as there could be many possible VMS
2533 * error statuses that caused the errno value to be set.
2536 int Perl_unix_status_to_vms(int unix_status)
2538 int test_unix_status;
2540 /* Trivial cases first */
2541 /*---------------------*/
2542 if (unix_status == EVMSERR)
2545 /* Is vaxc$errno sane? */
2546 /*---------------------*/
2547 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2548 if (test_unix_status == unix_status)
2551 /* If way out of range, must be VMS code already */
2552 /*-----------------------------------------------*/
2553 if (unix_status > EVMSERR)
2556 /* If out of range, punt */
2557 /*-----------------------*/
2558 if (unix_status > __ERRNO_MAX)
2562 /* Ok, now we have to do it the hard way. */
2563 /*----------------------------------------*/
2564 switch(unix_status) {
2565 case 0: return SS$_NORMAL;
2566 case EPERM: return SS$_NOPRIV;
2567 case ENOENT: return SS$_NOSUCHOBJECT;
2568 case ESRCH: return SS$_UNREACHABLE;
2569 case EINTR: return SS$_ABORT;
2572 case E2BIG: return SS$_BUFFEROVF;
2574 case EBADF: return RMS$_IFI;
2575 case ECHILD: return SS$_NONEXPR;
2577 case ENOMEM: return SS$_INSFMEM;
2578 case EACCES: return SS$_FILACCERR;
2579 case EFAULT: return SS$_ACCVIO;
2581 case EBUSY: return SS$_DEVOFFLINE;
2582 case EEXIST: return RMS$_FEX;
2584 case ENODEV: return SS$_NOSUCHDEV;
2585 case ENOTDIR: return RMS$_DIR;
2587 case EINVAL: return SS$_INVARG;
2593 case ENOSPC: return SS$_DEVICEFULL;
2594 case ESPIPE: return LIB$_INVARG;
2599 case ERANGE: return LIB$_INVARG;
2600 /* case EWOULDBLOCK */
2601 /* case EINPROGRESS */
2604 /* case EDESTADDRREQ */
2606 /* case EPROTOTYPE */
2607 /* case ENOPROTOOPT */
2608 /* case EPROTONOSUPPORT */
2609 /* case ESOCKTNOSUPPORT */
2610 /* case EOPNOTSUPP */
2611 /* case EPFNOSUPPORT */
2612 /* case EAFNOSUPPORT */
2613 /* case EADDRINUSE */
2614 /* case EADDRNOTAVAIL */
2616 /* case ENETUNREACH */
2617 /* case ENETRESET */
2618 /* case ECONNABORTED */
2619 /* case ECONNRESET */
2622 case ENOTCONN: return SS$_CLEARED;
2623 /* case ESHUTDOWN */
2624 /* case ETOOMANYREFS */
2625 /* case ETIMEDOUT */
2626 /* case ECONNREFUSED */
2628 /* case ENAMETOOLONG */
2629 /* case EHOSTDOWN */
2630 /* case EHOSTUNREACH */
2631 /* case ENOTEMPTY */
2643 /* case ECANCELED */
2647 return SS$_UNSUPPORTED;
2653 /* case EABANDONED */
2655 return SS$_ABORT; /* punt */
2658 return SS$_ABORT; /* Should not get here */
2662 /* default piping mailbox size */
2663 #define PERL_BUFSIZ 512
2667 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2669 unsigned long int mbxbufsiz;
2670 static unsigned long int syssize = 0;
2671 unsigned long int dviitm = DVI$_DEVNAM;
2672 char csize[LNM$C_NAMLENGTH+1];
2676 unsigned long syiitm = SYI$_MAXBUF;
2678 * Get the SYSGEN parameter MAXBUF
2680 * If the logical 'PERL_MBX_SIZE' is defined
2681 * use the value of the logical instead of PERL_BUFSIZ, but
2682 * keep the size between 128 and MAXBUF.
2685 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2688 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2689 mbxbufsiz = atoi(csize);
2691 mbxbufsiz = PERL_BUFSIZ;
2693 if (mbxbufsiz < 128) mbxbufsiz = 128;
2694 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2696 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2698 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2699 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2701 } /* end of create_mbx() */
2704 /*{{{ my_popen and my_pclose*/
2706 typedef struct _iosb IOSB;
2707 typedef struct _iosb* pIOSB;
2708 typedef struct _pipe Pipe;
2709 typedef struct _pipe* pPipe;
2710 typedef struct pipe_details Info;
2711 typedef struct pipe_details* pInfo;
2712 typedef struct _srqp RQE;
2713 typedef struct _srqp* pRQE;
2714 typedef struct _tochildbuf CBuf;
2715 typedef struct _tochildbuf* pCBuf;
2718 unsigned short status;
2719 unsigned short count;
2720 unsigned long dvispec;
2723 #pragma member_alignment save
2724 #pragma nomember_alignment quadword
2725 struct _srqp { /* VMS self-relative queue entry */
2726 unsigned long qptr[2];
2728 #pragma member_alignment restore
2729 static RQE RQE_ZERO = {0,0};
2731 struct _tochildbuf {
2734 unsigned short size;
2742 unsigned short chan_in;
2743 unsigned short chan_out;
2745 unsigned int bufsize;
2757 #if defined(PERL_IMPLICIT_CONTEXT)
2758 void *thx; /* Either a thread or an interpreter */
2759 /* pointer, depending on how we're built */
2767 PerlIO *fp; /* file pointer to pipe mailbox */
2768 int useFILE; /* using stdio, not perlio */
2769 int pid; /* PID of subprocess */
2770 int mode; /* == 'r' if pipe open for reading */
2771 int done; /* subprocess has completed */
2772 int waiting; /* waiting for completion/closure */
2773 int closing; /* my_pclose is closing this pipe */
2774 unsigned long completion; /* termination status of subprocess */
2775 pPipe in; /* pipe in to sub */
2776 pPipe out; /* pipe out of sub */
2777 pPipe err; /* pipe of sub's sys$error */
2778 int in_done; /* true when in pipe finished */
2781 unsigned short xchan; /* channel to debug xterm */
2782 unsigned short xchan_valid; /* channel is assigned */
2785 struct exit_control_block
2787 struct exit_control_block *flink;
2788 unsigned long int (*exit_routine)();
2789 unsigned long int arg_count;
2790 unsigned long int *status_address;
2791 unsigned long int exit_status;
2794 typedef struct _closed_pipes Xpipe;
2795 typedef struct _closed_pipes* pXpipe;
2797 struct _closed_pipes {
2798 int pid; /* PID of subprocess */
2799 unsigned long completion; /* termination status of subprocess */
2801 #define NKEEPCLOSED 50
2802 static Xpipe closed_list[NKEEPCLOSED];
2803 static int closed_index = 0;
2804 static int closed_num = 0;
2806 #define RETRY_DELAY "0 ::0.20"
2807 #define MAX_RETRY 50
2809 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2810 static unsigned long mypid;
2811 static unsigned long delaytime[2];
2813 static pInfo open_pipes = NULL;
2814 static $DESCRIPTOR(nl_desc, "NL:");
2816 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2820 static unsigned long int
2821 pipe_exit_routine(pTHX)
2824 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2825 int sts, did_stuff, need_eof, j;
2828 flush any pending i/o
2834 PerlIO_flush(info->fp); /* first, flush data */
2836 fflush((FILE *)info->fp);
2842 next we try sending an EOF...ignore if doesn't work, make sure we
2850 _ckvmssts_noperl(sys$setast(0));
2851 if (info->in && !info->in->shut_on_empty) {
2852 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2857 _ckvmssts_noperl(sys$setast(1));
2861 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2863 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2868 _ckvmssts_noperl(sys$setast(0));
2869 if (info->waiting && info->done)
2871 nwait += info->waiting;
2872 _ckvmssts_noperl(sys$setast(1));
2882 _ckvmssts_noperl(sys$setast(0));
2883 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2884 sts = sys$forcex(&info->pid,0,&abort);
2885 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2888 _ckvmssts_noperl(sys$setast(1));
2892 /* again, wait for effect */
2894 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2899 _ckvmssts_noperl(sys$setast(0));
2900 if (info->waiting && info->done)
2902 nwait += info->waiting;
2903 _ckvmssts_noperl(sys$setast(1));
2912 _ckvmssts_noperl(sys$setast(0));
2913 if (!info->done) { /* We tried to be nice . . . */
2914 sts = sys$delprc(&info->pid,0);
2915 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2916 info->done = 1; /* sys$delprc is as done as we're going to get. */
2918 _ckvmssts_noperl(sys$setast(1));
2923 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2924 else if (!(sts & 1)) retsts = sts;
2929 static struct exit_control_block pipe_exitblock =
2930 {(struct exit_control_block *) 0,
2931 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2933 static void pipe_mbxtofd_ast(pPipe p);
2934 static void pipe_tochild1_ast(pPipe p);
2935 static void pipe_tochild2_ast(pPipe p);
2938 popen_completion_ast(pInfo info)
2940 pInfo i = open_pipes;
2945 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2946 closed_list[closed_index].pid = info->pid;
2947 closed_list[closed_index].completion = info->completion;
2949 if (closed_index == NKEEPCLOSED)
2954 if (i == info) break;
2957 if (!i) return; /* unlinked, probably freed too */
2962 Writing to subprocess ...
2963 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2965 chan_out may be waiting for "done" flag, or hung waiting
2966 for i/o completion to child...cancel the i/o. This will
2967 put it into "snarf mode" (done but no EOF yet) that discards
2970 Output from subprocess (stdout, stderr) needs to be flushed and
2971 shut down. We try sending an EOF, but if the mbx is full the pipe
2972 routine should still catch the "shut_on_empty" flag, telling it to
2973 use immediate-style reads so that "mbx empty" -> EOF.
2977 if (info->in && !info->in_done) { /* only for mode=w */
2978 if (info->in->shut_on_empty && info->in->need_wake) {
2979 info->in->need_wake = FALSE;
2980 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2982 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2986 if (info->out && !info->out_done) { /* were we also piping output? */
2987 info->out->shut_on_empty = TRUE;
2988 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2989 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2990 _ckvmssts_noperl(iss);
2993 if (info->err && !info->err_done) { /* we were piping stderr */
2994 info->err->shut_on_empty = TRUE;
2995 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2996 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2997 _ckvmssts_noperl(iss);
2999 _ckvmssts_noperl(sys$setef(pipe_ef));
3003 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3004 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3007 we actually differ from vmstrnenv since we use this to
3008 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3009 are pointing to the same thing
3012 static unsigned short
3013 popen_translate(pTHX_ char *logical, char *result)
3016 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3017 $DESCRIPTOR(d_log,"");
3019 unsigned short length;
3020 unsigned short code;
3022 unsigned short *retlenaddr;
3024 unsigned short l, ifi;
3026 d_log.dsc$a_pointer = logical;
3027 d_log.dsc$w_length = strlen(logical);
3029 itmlst[0].code = LNM$_STRING;
3030 itmlst[0].length = 255;
3031 itmlst[0].buffer_addr = result;
3032 itmlst[0].retlenaddr = &l;
3035 itmlst[1].length = 0;
3036 itmlst[1].buffer_addr = 0;
3037 itmlst[1].retlenaddr = 0;
3039 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3040 if (iss == SS$_NOLOGNAM) {
3044 if (!(iss&1)) lib$signal(iss);
3047 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3048 strip it off and return the ifi, if any
3051 if (result[0] == 0x1b && result[1] == 0x00) {
3052 memmove(&ifi,result+2,2);
3053 strcpy(result,result+4);
3055 return ifi; /* this is the RMS internal file id */
3058 static void pipe_infromchild_ast(pPipe p);
3061 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3062 inside an AST routine without worrying about reentrancy and which Perl
3063 memory allocator is being used.
3065 We read data and queue up the buffers, then spit them out one at a
3066 time to the output mailbox when the output mailbox is ready for one.
3069 #define INITIAL_TOCHILDQUEUE 2
3072 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3076 char mbx1[64], mbx2[64];
3077 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3078 DSC$K_CLASS_S, mbx1},
3079 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3080 DSC$K_CLASS_S, mbx2};
3081 unsigned int dviitm = DVI$_DEVBUFSIZ;
3085 _ckvmssts(lib$get_vm(&n, &p));
3087 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3088 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3089 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3092 p->shut_on_empty = FALSE;
3093 p->need_wake = FALSE;
3096 p->iosb.status = SS$_NORMAL;
3097 p->iosb2.status = SS$_NORMAL;
3103 #ifdef PERL_IMPLICIT_CONTEXT
3107 n = sizeof(CBuf) + p->bufsize;
3109 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3110 _ckvmssts(lib$get_vm(&n, &b));
3111 b->buf = (char *) b + sizeof(CBuf);
3112 _ckvmssts(lib$insqhi(b, &p->free));
3115 pipe_tochild2_ast(p);
3116 pipe_tochild1_ast(p);
3122 /* reads the MBX Perl is writing, and queues */
3125 pipe_tochild1_ast(pPipe p)
3128 int iss = p->iosb.status;
3129 int eof = (iss == SS$_ENDOFFILE);
3131 #ifdef PERL_IMPLICIT_CONTEXT
3137 p->shut_on_empty = TRUE;
3139 _ckvmssts(sys$dassgn(p->chan_in));
3145 b->size = p->iosb.count;
3146 _ckvmssts(sts = lib$insqhi(b, &p->wait));
3148 p->need_wake = FALSE;
3149 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3152 p->retry = 1; /* initial call */
3155 if (eof) { /* flush the free queue, return when done */
3156 int n = sizeof(CBuf) + p->bufsize;
3158 iss = lib$remqti(&p->free, &b);
3159 if (iss == LIB$_QUEWASEMP) return;
3161 _ckvmssts(lib$free_vm(&n, &b));
3165 iss = lib$remqti(&p->free, &b);
3166 if (iss == LIB$_QUEWASEMP) {
3167 int n = sizeof(CBuf) + p->bufsize;
3168 _ckvmssts(lib$get_vm(&n, &b));
3169 b->buf = (char *) b + sizeof(CBuf);
3175 iss = sys$qio(0,p->chan_in,
3176 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3178 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3179 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3184 /* writes queued buffers to output, waits for each to complete before
3188 pipe_tochild2_ast(pPipe p)
3191 int iss = p->iosb2.status;
3192 int n = sizeof(CBuf) + p->bufsize;
3193 int done = (p->info && p->info->done) ||
3194 iss == SS$_CANCEL || iss == SS$_ABORT;
3195 #if defined(PERL_IMPLICIT_CONTEXT)
3200 if (p->type) { /* type=1 has old buffer, dispose */
3201 if (p->shut_on_empty) {
3202 _ckvmssts(lib$free_vm(&n, &b));
3204 _ckvmssts(lib$insqhi(b, &p->free));
3209 iss = lib$remqti(&p->wait, &b);
3210 if (iss == LIB$_QUEWASEMP) {
3211 if (p->shut_on_empty) {
3213 _ckvmssts(sys$dassgn(p->chan_out));
3214 *p->pipe_done = TRUE;
3215 _ckvmssts(sys$setef(pipe_ef));
3217 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3218 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3222 p->need_wake = TRUE;
3232 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3233 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3235 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3236 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3245 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3248 char mbx1[64], mbx2[64];
3249 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3250 DSC$K_CLASS_S, mbx1},
3251 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3252 DSC$K_CLASS_S, mbx2};
3253 unsigned int dviitm = DVI$_DEVBUFSIZ;
3255 int n = sizeof(Pipe);
3256 _ckvmssts(lib$get_vm(&n, &p));
3257 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3258 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3260 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3261 n = p->bufsize * sizeof(char);
3262 _ckvmssts(lib$get_vm(&n, &p->buf));
3263 p->shut_on_empty = FALSE;
3266 p->iosb.status = SS$_NORMAL;
3267 #if defined(PERL_IMPLICIT_CONTEXT)
3270 pipe_infromchild_ast(p);
3278 pipe_infromchild_ast(pPipe p)
3280 int iss = p->iosb.status;
3281 int eof = (iss == SS$_ENDOFFILE);
3282 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3283 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3284 #if defined(PERL_IMPLICIT_CONTEXT)
3288 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3289 _ckvmssts(sys$dassgn(p->chan_out));
3294 input shutdown if EOF from self (done or shut_on_empty)
3295 output shutdown if closing flag set (my_pclose)
3296 send data/eof from child or eof from self
3297 otherwise, re-read (snarf of data from child)
3302 if (myeof && p->chan_in) { /* input shutdown */
3303 _ckvmssts(sys$dassgn(p->chan_in));
3308 if (myeof || kideof) { /* pass EOF to parent */
3309 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3310 pipe_infromchild_ast, p,
3313 } else if (eof) { /* eat EOF --- fall through to read*/
3315 } else { /* transmit data */
3316 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3317 pipe_infromchild_ast,p,
3318 p->buf, p->iosb.count, 0, 0, 0, 0));
3324 /* everything shut? flag as done */
3326 if (!p->chan_in && !p->chan_out) {
3327 *p->pipe_done = TRUE;
3328 _ckvmssts(sys$setef(pipe_ef));
3332 /* write completed (or read, if snarfing from child)
3333 if still have input active,
3334 queue read...immediate mode if shut_on_empty so we get EOF if empty
3336 check if Perl reading, generate EOFs as needed
3342 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3343 pipe_infromchild_ast,p,
3344 p->buf, p->bufsize, 0, 0, 0, 0);
3345 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3347 } else { /* send EOFs for extra reads */
3348 p->iosb.status = SS$_ENDOFFILE;
3349 p->iosb.dvispec = 0;
3350 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3352 pipe_infromchild_ast, p, 0, 0, 0, 0));
3358 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3362 unsigned long dviitm = DVI$_DEVBUFSIZ;
3364 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3365 DSC$K_CLASS_S, mbx};
3366 int n = sizeof(Pipe);
3368 /* things like terminals and mbx's don't need this filter */
3369 if (fd && fstat(fd,&s) == 0) {
3370 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3372 unsigned short dev_len;
3373 struct dsc$descriptor_s d_dev;
3375 struct item_list_3 items[3];
3377 unsigned short dvi_iosb[4];
3379 cptr = getname(fd, out, 1);
3380 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3381 d_dev.dsc$a_pointer = out;
3382 d_dev.dsc$w_length = strlen(out);
3383 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3384 d_dev.dsc$b_class = DSC$K_CLASS_S;
3387 items[0].code = DVI$_DEVCHAR;
3388 items[0].bufadr = &devchar;
3389 items[0].retadr = NULL;
3391 items[1].code = DVI$_FULLDEVNAM;
3392 items[1].bufadr = device;
3393 items[1].retadr = &dev_len;
3397 status = sys$getdviw
3398 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3400 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3401 device[dev_len] = 0;
3403 if (!(devchar & DEV$M_DIR)) {
3404 strcpy(out, device);
3410 _ckvmssts(lib$get_vm(&n, &p));
3411 p->fd_out = dup(fd);
3412 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3413 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3414 n = (p->bufsize+1) * sizeof(char);
3415 _ckvmssts(lib$get_vm(&n, &p->buf));
3416 p->shut_on_empty = FALSE;
3421 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3422 pipe_mbxtofd_ast, p,
3423 p->buf, p->bufsize, 0, 0, 0, 0));
3429 pipe_mbxtofd_ast(pPipe p)
3431 int iss = p->iosb.status;
3432 int done = p->info->done;
3434 int eof = (iss == SS$_ENDOFFILE);
3435 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3436 int err = !(iss&1) && !eof;
3437 #if defined(PERL_IMPLICIT_CONTEXT)
3441 if (done && myeof) { /* end piping */
3443 sys$dassgn(p->chan_in);
3444 *p->pipe_done = TRUE;
3445 _ckvmssts(sys$setef(pipe_ef));
3449 if (!err && !eof) { /* good data to send to file */
3450 p->buf[p->iosb.count] = '\n';
3451 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3454 if (p->retry < MAX_RETRY) {
3455 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3465 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3466 pipe_mbxtofd_ast, p,
3467 p->buf, p->bufsize, 0, 0, 0, 0);
3468 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3473 typedef struct _pipeloc PLOC;
3474 typedef struct _pipeloc* pPLOC;
3478 char dir[NAM$C_MAXRSS+1];
3480 static pPLOC head_PLOC = 0;
3483 free_pipelocs(pTHX_ void *head)
3486 pPLOC *pHead = (pPLOC *)head;
3498 store_pipelocs(pTHX)
3507 char temp[NAM$C_MAXRSS+1];
3511 free_pipelocs(aTHX_ &head_PLOC);
3513 /* the . directory from @INC comes last */
3515 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3516 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3517 p->next = head_PLOC;
3519 strcpy(p->dir,"./");
3521 /* get the directory from $^X */
3523 unixdir = PerlMem_malloc(VMS_MAXRSS);
3524 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3526 #ifdef PERL_IMPLICIT_CONTEXT
3527 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3529 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3531 strcpy(temp, PL_origargv[0]);
3532 x = strrchr(temp,']');
3534 x = strrchr(temp,'>');
3536 /* It could be a UNIX path */
3537 x = strrchr(temp,'/');
3543 /* Got a bare name, so use default directory */
3548 if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3549 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3550 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3551 p->next = head_PLOC;
3553 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3554 p->dir[NAM$C_MAXRSS] = '\0';
3558 /* reverse order of @INC entries, skip "." since entered above */
3560 #ifdef PERL_IMPLICIT_CONTEXT
3563 if (PL_incgv) av = GvAVn(PL_incgv);
3565 for (i = 0; av && i <= AvFILL(av); i++) {
3566 dirsv = *av_fetch(av,i,TRUE);
3568 if (SvROK(dirsv)) continue;
3569 dir = SvPVx(dirsv,n_a);
3570 if (strcmp(dir,".") == 0) continue;
3571 if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3574 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3575 p->next = head_PLOC;
3577 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3578 p->dir[NAM$C_MAXRSS] = '\0';
3581 /* most likely spot (ARCHLIB) put first in the list */
3584 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3585 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3586 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3587 p->next = head_PLOC;
3589 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3590 p->dir[NAM$C_MAXRSS] = '\0';
3593 PerlMem_free(unixdir);
3597 Perl_cando_by_name_int
3598 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3599 #if !defined(PERL_IMPLICIT_CONTEXT)
3600 #define cando_by_name_int Perl_cando_by_name_int
3602 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3608 static int vmspipe_file_status = 0;
3609 static char vmspipe_file[NAM$C_MAXRSS+1];
3611 /* already found? Check and use ... need read+execute permission */
3613 if (vmspipe_file_status == 1) {
3614 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3615 && cando_by_name_int
3616 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3617 return vmspipe_file;
3619 vmspipe_file_status = 0;
3622 /* scan through stored @INC, $^X */
3624 if (vmspipe_file_status == 0) {
3625 char file[NAM$C_MAXRSS+1];
3626 pPLOC p = head_PLOC;
3631 strcpy(file, p->dir);
3632 dirlen = strlen(file);
3633 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3634 file[NAM$C_MAXRSS] = '\0';
3637 exp_res = do_rmsexpand
3638 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3639 if (!exp_res) continue;
3641 if (cando_by_name_int
3642 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3643 && cando_by_name_int
3644 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3645 vmspipe_file_status = 1;
3646 return vmspipe_file;
3649 vmspipe_file_status = -1; /* failed, use tempfiles */
3656 vmspipe_tempfile(pTHX)
3658 char file[NAM$C_MAXRSS+1];
3660 static int index = 0;
3664 /* create a tempfile */
3666 /* we can't go from W, shr=get to R, shr=get without
3667 an intermediate vulnerable state, so don't bother trying...
3669 and lib$spawn doesn't shr=put, so have to close the write
3671 So... match up the creation date/time and the FID to
3672 make sure we're dealing with the same file
3677 if (!decc_filename_unix_only) {
3678 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3679 fp = fopen(file,"w");
3681 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3682 fp = fopen(file,"w");
3684 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3685 fp = fopen(file,"w");
3690 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3691 fp = fopen(file,"w");
3693 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3694 fp = fopen(file,"w");
3696 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3697 fp = fopen(file,"w");
3701 if (!fp) return 0; /* we're hosed */
3703 fprintf(fp,"$! 'f$verify(0)'\n");
3704 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3705 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3706 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3707 fprintf(fp,"$ perl_on = \"set noon\"\n");
3708 fprintf(fp,"$ perl_exit = \"exit\"\n");
3709 fprintf(fp,"$ perl_del = \"delete\"\n");
3710 fprintf(fp,"$ pif = \"if\"\n");
3711 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3712 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3713 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3714 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3715 fprintf(fp,"$! --- build command line to get max possible length\n");
3716 fprintf(fp,"$c=perl_popen_cmd0\n");
3717 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3718 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3719 fprintf(fp,"$x=perl_popen_cmd3\n");
3720 fprintf(fp,"$c=c+x\n");
3721 fprintf(fp,"$ perl_on\n");
3722 fprintf(fp,"$ 'c'\n");
3723 fprintf(fp,"$ perl_status = $STATUS\n");
3724 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3725 fprintf(fp,"$ perl_exit 'perl_status'\n");
3728 fgetname(fp, file, 1);
3729 fstat(fileno(fp), (struct stat *)&s0);
3732 if (decc_filename_unix_only)
3733 do_tounixspec(file, file, 0, NULL);
3734 fp = fopen(file,"r","shr=get");
3736 fstat(fileno(fp), (struct stat *)&s1);
3738 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3739 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3748 #ifdef USE_VMS_DECTERM
3750 static int vms_is_syscommand_xterm(void)
3752 const static struct dsc$descriptor_s syscommand_dsc =
3753 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3755 const static struct dsc$descriptor_s decwdisplay_dsc =
3756 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3758 struct item_list_3 items[2];
3759 unsigned short dvi_iosb[4];
3760 unsigned long devchar;
3761 unsigned long devclass;
3764 /* Very simple check to guess if sys$command is a decterm? */
3765 /* First see if the DECW$DISPLAY: device exists */
3767 items[0].code = DVI$_DEVCHAR;
3768 items[0].bufadr = &devchar;
3769 items[0].retadr = NULL;
3773 status = sys$getdviw
3774 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3776 if ($VMS_STATUS_SUCCESS(status)) {
3777 status = dvi_iosb[0];
3780 if (!$VMS_STATUS_SUCCESS(status)) {
3781 SETERRNO(EVMSERR, status);
3785 /* If it does, then for now assume that we are on a workstation */
3786 /* Now verify that SYS$COMMAND is a terminal */
3787 /* for creating the debugger DECTerm */
3790 items[0].code = DVI$_DEVCLASS;
3791 items[0].bufadr = &devclass;
3792 items[0].retadr = NULL;
3796 status = sys$getdviw
3797 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3799 if ($VMS_STATUS_SUCCESS(status)) {
3800 status = dvi_iosb[0];
3803 if (!$VMS_STATUS_SUCCESS(status)) {
3804 SETERRNO(EVMSERR, status);
3808 if (devclass == DC$_TERM) {
3815 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3816 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3821 char device_name[65];
3822 unsigned short device_name_len;
3823 struct dsc$descriptor_s customization_dsc;
3824 struct dsc$descriptor_s device_name_dsc;
3827 char customization[200];
3831 unsigned short p_chan;
3833 unsigned short iosb[4];
3834 struct item_list_3 items[2];
3835 const char * cust_str =
3836 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3837 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3838 DSC$K_CLASS_S, mbx1};
3840 ret_char = strstr(cmd," xterm ");
3841 if (ret_char == NULL)
3843 cptr = ret_char + 7;
3844 ret_char = strstr(cmd,"tty");
3845 if (ret_char == NULL)
3847 ret_char = strstr(cmd,"sleep");
3848 if (ret_char == NULL)
3851 /* Are we on a workstation? */
3852 /* to do: capture the rows / columns and pass their properties */
3853 ret_stat = vms_is_syscommand_xterm();
3857 /* Make the title: */
3858 ret_char = strstr(cptr,"-title");
3859 if (ret_char != NULL) {
3860 while ((*cptr != 0) && (*cptr != '\"')) {
3866 while ((*cptr != 0) && (*cptr != '\"')) {
3879 strcpy(title,"Perl Debug DECTerm");
3881 sprintf(customization, cust_str, title);
3883 customization_dsc.dsc$a_pointer = customization;
3884 customization_dsc.dsc$w_length = strlen(customization);
3885 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3886 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3888 device_name_dsc.dsc$a_pointer = device_name;
3889 device_name_dsc.dsc$w_length = sizeof device_name -1;
3890 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3891 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3893 device_name_len = 0;
3895 /* Try to create the window */
3896 status = decw$term_port
3905 if (!$VMS_STATUS_SUCCESS(status)) {
3906 SETERRNO(EVMSERR, status);
3910 device_name[device_name_len] = '\0';
3912 /* Need to set this up to look like a pipe for cleanup */
3914 status = lib$get_vm(&n, &info);
3915 if (!$VMS_STATUS_SUCCESS(status)) {
3916 SETERRNO(ENOMEM, status);
3922 info->completion = 0;
3923 info->closing = FALSE;
3930 info->in_done = TRUE;
3931 info->out_done = TRUE;
3932 info->err_done = TRUE;
3934 /* Assign a channel on this so that it will persist, and not login */
3935 /* We stash this channel in the info structure for reference. */
3936 /* The created xterm self destructs when the last channel is removed */
3937 /* and it appears that perl5db.pl (perl debugger) does this routinely */
3938 /* So leave this assigned. */
3939 device_name_dsc.dsc$w_length = device_name_len;
3940 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
3941 if (!$VMS_STATUS_SUCCESS(status)) {
3942 SETERRNO(EVMSERR, status);
3945 info->xchan_valid = 1;
3947 /* Now create a mailbox to be read by the application */
3949 create_mbx(aTHX_ &p_chan, &d_mbx1);
3951 /* write the name of the created terminal to the mailbox */
3952 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
3953 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
3955 if (!$VMS_STATUS_SUCCESS(status)) {
3956 SETERRNO(EVMSERR, status);
3960 info->fp = PerlIO_open(mbx1, mode);
3962 /* Done with this channel */
3965 /* If any errors, then clean up */
3968 _ckvmssts(lib$free_vm(&n, &info));
3978 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3980 static int handler_set_up = FALSE;
3981 unsigned long int sts, flags = CLI$M_NOWAIT;
3982 /* The use of a GLOBAL table (as was done previously) rendered
3983 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3984 * environment. Hence we've switched to LOCAL symbol table.
3986 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3988 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3989 char *in, *out, *err, mbx[512];
3991 char tfilebuf[NAM$C_MAXRSS+1];
3993 char cmd_sym_name[20];
3994 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3995 DSC$K_CLASS_S, symbol};
3996 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3998 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3999 DSC$K_CLASS_S, cmd_sym_name};
4000 struct dsc$descriptor_s *vmscmd;
4001 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4002 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4003 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4005 #ifdef USE_VMS_DECTERM
4006 /* Check here for Xterm create request. This means looking for
4007 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4008 * is possible to create an xterm.
4010 if (*in_mode == 'r') {
4013 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4014 if (xterm_fd != Nullfp)
4019 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4021 /* once-per-program initialization...
4022 note that the SETAST calls and the dual test of pipe_ef
4023 makes sure that only the FIRST thread through here does
4024 the initialization...all other threads wait until it's
4027 Yeah, uglier than a pthread call, it's got all the stuff inline
4028 rather than in a separate routine.
4032 _ckvmssts(sys$setast(0));
4034 unsigned long int pidcode = JPI$_PID;
4035 $DESCRIPTOR(d_delay, RETRY_DELAY);
4036 _ckvmssts(lib$get_ef(&pipe_ef));
4037 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4038 _ckvmssts(sys$bintim(&d_delay, delaytime));
4040 if (!handler_set_up) {
4041 _ckvmssts(sys$dclexh(&pipe_exitblock));
4042 handler_set_up = TRUE;
4044 _ckvmssts(sys$setast(1));
4047 /* see if we can find a VMSPIPE.COM */
4050 vmspipe = find_vmspipe(aTHX);
4052 strcpy(tfilebuf+1,vmspipe);
4053 } else { /* uh, oh...we're in tempfile hell */
4054 tpipe = vmspipe_tempfile(aTHX);
4055 if (!tpipe) { /* a fish popular in Boston */
4056 if (ckWARN(WARN_PIPE)) {
4057 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4061 fgetname(tpipe,tfilebuf+1,1);
4063 vmspipedsc.dsc$a_pointer = tfilebuf;
4064 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4066 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4069 case RMS$_FNF: case RMS$_DNF:
4070 set_errno(ENOENT); break;
4072 set_errno(ENOTDIR); break;
4074 set_errno(ENODEV); break;
4076 set_errno(EACCES); break;
4078 set_errno(EINVAL); break;
4079 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4080 set_errno(E2BIG); break;
4081 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4082 _ckvmssts(sts); /* fall through */
4083 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4086 set_vaxc_errno(sts);
4087 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4088 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4094 _ckvmssts(lib$get_vm(&n, &info));
4096 strcpy(mode,in_mode);
4099 info->completion = 0;
4100 info->closing = FALSE;
4107 info->in_done = TRUE;
4108 info->out_done = TRUE;
4109 info->err_done = TRUE;
4111 info->xchan_valid = 0;
4113 in = PerlMem_malloc(VMS_MAXRSS);
4114 if (in == NULL) _ckvmssts(SS$_INSFMEM);
4115 out = PerlMem_malloc(VMS_MAXRSS);
4116 if (out == NULL) _ckvmssts(SS$_INSFMEM);
4117 err = PerlMem_malloc(VMS_MAXRSS);
4118 if (err == NULL) _ckvmssts(SS$_INSFMEM);
4120 in[0] = out[0] = err[0] = '\0';
4122 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4126 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4131 if (*mode == 'r') { /* piping from subroutine */
4133 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4135 info->out->pipe_done = &info->out_done;
4136 info->out_done = FALSE;
4137 info->out->info = info;
4139 if (!info->useFILE) {
4140 info->fp = PerlIO_open(mbx, mode);
4142 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4143 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4146 if (!info->fp && info->out) {
4147 sys$cancel(info->out->chan_out);
4149 while (!info->out_done) {
4151 _ckvmssts(sys$setast(0));
4152 done = info->out_done;
4153 if (!done) _ckvmssts(sys$clref(pipe_ef));
4154 _ckvmssts(sys$setast(1));
4155 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4158 if (info->out->buf) {
4159 n = info->out->bufsize * sizeof(char);
4160 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4163 _ckvmssts(lib$free_vm(&n, &info->out));
4165 _ckvmssts(lib$free_vm(&n, &info));
4170 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4172 info->err->pipe_done = &info->err_done;
4173 info->err_done = FALSE;
4174 info->err->info = info;
4177 } else if (*mode == 'w') { /* piping to subroutine */
4179 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4181 info->out->pipe_done = &info->out_done;
4182 info->out_done = FALSE;
4183 info->out->info = info;
4186 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4188 info->err->pipe_done = &info->err_done;
4189 info->err_done = FALSE;
4190 info->err->info = info;
4193 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4194 if (!info->useFILE) {
4195 info->fp = PerlIO_open(mbx, mode);
4197 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4198 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4202 info->in->pipe_done = &info->in_done;
4203 info->in_done = FALSE;
4204 info->in->info = info;
4208 if (!info->fp && info->in) {
4210 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4211 0, 0, 0, 0, 0, 0, 0, 0));
4213 while (!info->in_done) {
4215 _ckvmssts(sys$setast(0));
4216 done = info->in_done;
4217 if (!done) _ckvmssts(sys$clref(pipe_ef));
4218 _ckvmssts(sys$setast(1));
4219 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4222 if (info->in->buf) {
4223 n = info->in->bufsize * sizeof(char);
4224 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4227 _ckvmssts(lib$free_vm(&n, &info->in));
4229 _ckvmssts(lib$free_vm(&n, &info));
4235 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4236 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4238 info->out->pipe_done = &info->out_done;
4239 info->out_done = FALSE;
4240 info->out->info = info;
4243 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4245 info->err->pipe_done = &info->err_done;
4246 info->err_done = FALSE;
4247 info->err->info = info;
4251 symbol[MAX_DCL_SYMBOL] = '\0';
4253 strncpy(symbol, in, MAX_DCL_SYMBOL);
4254 d_symbol.dsc$w_length = strlen(symbol);
4255 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4257 strncpy(symbol, err, MAX_DCL_SYMBOL);
4258 d_symbol.dsc$w_length = strlen(symbol);
4259 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4261 strncpy(symbol, out, MAX_DCL_SYMBOL);
4262 d_symbol.dsc$w_length = strlen(symbol);
4263 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4265 /* Done with the names for the pipes */
4270 p = vmscmd->dsc$a_pointer;
4271 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4272 if (*p == '$') p++; /* remove leading $ */
4273 while (*p == ' ' || *p == '\t') p++;
4275 for (j = 0; j < 4; j++) {
4276 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4277 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4279 strncpy(symbol, p, MAX_DCL_SYMBOL);
4280 d_symbol.dsc$w_length = strlen(symbol);
4281 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4283 if (strlen(p) > MAX_DCL_SYMBOL) {
4284 p += MAX_DCL_SYMBOL;
4289 _ckvmssts(sys$setast(0));
4290 info->next=open_pipes; /* prepend to list */
4292 _ckvmssts(sys$setast(1));
4293 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4294 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4295 * have SYS$COMMAND if we need it.
4297 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4298 0, &info->pid, &info->completion,
4299 0, popen_completion_ast,info,0,0,0));
4301 /* if we were using a tempfile, close it now */
4303 if (tpipe) fclose(tpipe);
4305 /* once the subprocess is spawned, it has copied the symbols and
4306 we can get rid of ours */
4308 for (j = 0; j < 4; j++) {
4309 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4310 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4311 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4313 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4314 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4315 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4316 vms_execfree(vmscmd);
4318 #ifdef PERL_IMPLICIT_CONTEXT
4321 PL_forkprocess = info->pid;
4326 _ckvmssts(sys$setast(0));
4328 if (!done) _ckvmssts(sys$clref(pipe_ef));
4329 _ckvmssts(sys$setast(1));
4330 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4332 *psts = info->completion;
4333 /* Caller thinks it is open and tries to close it. */
4334 /* This causes some problems, as it changes the error status */
4335 /* my_pclose(info->fp); */
4340 } /* end of safe_popen */
4343 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4345 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4349 TAINT_PROPER("popen");
4350 PERL_FLUSHALL_FOR_CHILD;
4351 return safe_popen(aTHX_ cmd,mode,&sts);
4356 /*{{{ I32 my_pclose(PerlIO *fp)*/
4357 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4359 pInfo info, last = NULL;
4360 unsigned long int retsts;
4364 for (info = open_pipes; info != NULL; last = info, info = info->next)
4365 if (info->fp == fp) break;
4367 if (info == NULL) { /* no such pipe open */
4368 set_errno(ECHILD); /* quoth POSIX */
4369 set_vaxc_errno(SS$_NONEXPR);
4373 /* If we were writing to a subprocess, insure that someone reading from
4374 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4375 * produce an EOF record in the mailbox.
4377 * well, at least sometimes it *does*, so we have to watch out for
4378 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4382 PerlIO_flush(info->fp); /* first, flush data */
4384 fflush((FILE *)info->fp);
4387 _ckvmssts(sys$setast(0));
4388 info->closing = TRUE;
4389 done = info->done && info->in_done && info->out_done && info->err_done;
4390 /* hanging on write to Perl's input? cancel it */
4391 if (info->mode == 'r' && info->out && !info->out_done) {
4392 if (info->out->chan_out) {
4393 _ckvmssts(sys$cancel(info->out->chan_out));
4394 if (!info->out->chan_in) { /* EOF generation, need AST */
4395 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4399 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4400 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4402 _ckvmssts(sys$setast(1));
4405 PerlIO_close(info->fp);
4407 fclose((FILE *)info->fp);
4410 we have to wait until subprocess completes, but ALSO wait until all
4411 the i/o completes...otherwise we'll be freeing the "info" structure
4412 that the i/o ASTs could still be using...
4416 _ckvmssts(sys$setast(0));
4417 done = info->done && info->in_done && info->out_done && info->err_done;
4418 if (!done) _ckvmssts(sys$clref(pipe_ef));
4419 _ckvmssts(sys$setast(1));
4420 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4422 retsts = info->completion;
4424 /* remove from list of open pipes */
4425 _ckvmssts(sys$setast(0));
4426 if (last) last->next = info->next;
4427 else open_pipes = info->next;
4428 _ckvmssts(sys$setast(1));
4430 /* free buffers and structures */
4433 if (info->in->buf) {
4434 n = info->in->bufsize * sizeof(char);
4435 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4438 _ckvmssts(lib$free_vm(&n, &info->in));
4441 if (info->out->buf) {
4442 n = info->out->bufsize * sizeof(char);
4443 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4446 _ckvmssts(lib$free_vm(&n, &info->out));
4449 if (info->err->buf) {
4450 n = info->err->bufsize * sizeof(char);
4451 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4454 _ckvmssts(lib$free_vm(&n, &info->err));
4457 _ckvmssts(lib$free_vm(&n, &info));
4461 } /* end of my_pclose() */
4463 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4464 /* Roll our own prototype because we want this regardless of whether
4465 * _VMS_WAIT is defined.
4467 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4469 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4470 created with popen(); otherwise partially emulate waitpid() unless
4471 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4472 Also check processes not considered by the CRTL waitpid().
4474 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4476 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4483 if (statusp) *statusp = 0;
4485 for (info = open_pipes; info != NULL; info = info->next)
4486 if (info->pid == pid) break;
4488 if (info != NULL) { /* we know about this child */
4489 while (!info->done) {
4490 _ckvmssts(sys$setast(0));
4492 if (!done) _ckvmssts(sys$clref(pipe_ef));
4493 _ckvmssts(sys$setast(1));
4494 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4497 if (statusp) *statusp = info->completion;
4501 /* child that already terminated? */
4503 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4504 if (closed_list[j].pid == pid) {
4505 if (statusp) *statusp = closed_list[j].completion;
4510 /* fall through if this child is not one of our own pipe children */
4512 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4514 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4515 * in 7.2 did we get a version that fills in the VMS completion
4516 * status as Perl has always tried to do.
4519 sts = __vms_waitpid( pid, statusp, flags );
4521 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4524 /* If the real waitpid tells us the child does not exist, we
4525 * fall through here to implement waiting for a child that
4526 * was created by some means other than exec() (say, spawned
4527 * from DCL) or to wait for a process that is not a subprocess
4528 * of the current process.
4531 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4534 $DESCRIPTOR(intdsc,"0 00:00:01");
4535 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4536 unsigned long int pidcode = JPI$_PID, mypid;
4537 unsigned long int interval[2];
4538 unsigned int jpi_iosb[2];
4539 struct itmlst_3 jpilist[2] = {
4540 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4545 /* Sorry folks, we don't presently implement rooting around for
4546 the first child we can find, and we definitely don't want to
4547 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4553 /* Get the owner of the child so I can warn if it's not mine. If the
4554 * process doesn't exist or I don't have the privs to look at it,
4555 * I can go home early.
4557 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4558 if (sts & 1) sts = jpi_iosb[0];
4570 set_vaxc_errno(sts);
4574 if (ckWARN(WARN_EXEC)) {
4575 /* remind folks they are asking for non-standard waitpid behavior */
4576 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4577 if (ownerpid != mypid)
4578 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4579 "waitpid: process %x is not a child of process %x",
4583 /* simply check on it once a second until it's not there anymore. */
4585 _ckvmssts(sys$bintim(&intdsc,interval));
4586 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4587 _ckvmssts(sys$schdwk(0,0,interval,0));
4588 _ckvmssts(sys$hiber());
4590 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4595 } /* end of waitpid() */
4600 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4602 my_gconvert(double val, int ndig, int trail, char *buf)
4604 static char __gcvtbuf[DBL_DIG+1];
4607 loc = buf ? buf : __gcvtbuf;
4609 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4611 sprintf(loc,"%.*g",ndig,val);
4617 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4618 return gcvt(val,ndig,loc);
4621 loc[0] = '0'; loc[1] = '\0';
4628 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4629 static int rms_free_search_context(struct FAB * fab)
4633 nam = fab->fab$l_nam;
4634 nam->nam$b_nop |= NAM$M_SYNCHK;
4635 nam->nam$l_rlf = NULL;
4637 return sys$parse(fab, NULL, NULL);
4640 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4641 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4642 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4643 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4644 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4645 #define rms_nam_esll(nam) nam.nam$b_esl
4646 #define rms_nam_esl(nam) nam.nam$b_esl
4647 #define rms_nam_name(nam) nam.nam$l_name
4648 #define rms_nam_namel(nam) nam.nam$l_name
4649 #define rms_nam_type(nam) nam.nam$l_type
4650 #define rms_nam_typel(nam) nam.nam$l_type
4651 #define rms_nam_ver(nam) nam.nam$l_ver
4652 #define rms_nam_verl(nam) nam.nam$l_ver
4653 #define rms_nam_rsll(nam) nam.nam$b_rsl
4654 #define rms_nam_rsl(nam) nam.nam$b_rsl
4655 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4656 #define rms_set_fna(fab, nam, name, size) \
4657 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4658 #define rms_get_fna(fab, nam) fab.fab$l_fna
4659 #define rms_set_dna(fab, nam, name, size) \
4660 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4661 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4662 #define rms_set_esa(fab, nam, name, size) \
4663 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4664 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4665 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4666 #define rms_set_rsa(nam, name, size) \
4667 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4668 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4669 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4670 #define rms_nam_name_type_l_size(nam) \
4671 (nam.nam$b_name + nam.nam$b_type)
4673 static int rms_free_search_context(struct FAB * fab)
4677 nam = fab->fab$l_naml;
4678 nam->naml$b_nop |= NAM$M_SYNCHK;
4679 nam->naml$l_rlf = NULL;
4680 nam->naml$l_long_defname_size = 0;
4683 return sys$parse(fab, NULL, NULL);
4686 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4687 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4688 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4689 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4690 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4691 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4692 #define rms_nam_esl(nam) nam.naml$b_esl
4693 #define rms_nam_name(nam) nam.naml$l_name
4694 #define rms_nam_namel(nam) nam.naml$l_long_name
4695 #define rms_nam_type(nam) nam.naml$l_type
4696 #define rms_nam_typel(nam) nam.naml$l_long_type
4697 #define rms_nam_ver(nam) nam.naml$l_ver
4698 #define rms_nam_verl(nam) nam.naml$l_long_ver
4699 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4700 #define rms_nam_rsl(nam) nam.naml$b_rsl
4701 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4702 #define rms_set_fna(fab, nam, name, size) \
4703 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4704 nam.naml$l_long_filename_size = size; \
4705 nam.naml$l_long_filename = name;}
4706 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4707 #define rms_set_dna(fab, nam, name, size) \
4708 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4709 nam.naml$l_long_defname_size = size; \
4710 nam.naml$l_long_defname = name; }
4711 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4712 #define rms_set_esa(fab, nam, name, size) \
4713 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4714 nam.naml$l_long_expand_alloc = size; \
4715 nam.naml$l_long_expand = name; }
4716 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4717 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4718 nam.naml$l_long_expand = l_name; \
4719 nam.naml$l_long_expand_alloc = l_size; }
4720 #define rms_set_rsa(nam, name, size) \
4721 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4722 nam.naml$l_long_result = name; \
4723 nam.naml$l_long_result_alloc = size; }
4724 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4725 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4726 nam.naml$l_long_result = l_name; \
4727 nam.naml$l_long_result_alloc = l_size; }
4728 #define rms_nam_name_type_l_size(nam) \
4729 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4733 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4734 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4735 * to expand file specification. Allows for a single default file
4736 * specification and a simple mask of options. If outbuf is non-NULL,
4737 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4738 * the resultant file specification is placed. If outbuf is NULL, the
4739 * resultant file specification is placed into a static buffer.
4740 * The third argument, if non-NULL, is taken to be a default file
4741 * specification string. The fourth argument is unused at present.
4742 * rmesexpand() returns the address of the resultant string if
4743 * successful, and NULL on error.
4745 * New functionality for previously unused opts value:
4746 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4747 * PERL_RMSEXPAND_M_LONG - Want output in long formst
4748 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4750 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4754 (pTHX_ const char *filespec,
4757 const char *defspec,
4762 static char __rmsexpand_retbuf[VMS_MAXRSS];
4763 char * vmsfspec, *tmpfspec;
4764 char * esa, *cp, *out = NULL;
4768 struct FAB myfab = cc$rms_fab;
4769 rms_setup_nam(mynam);
4771 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4774 /* temp hack until UTF8 is actually implemented */
4775 if (fs_utf8 != NULL)
4778 if (!filespec || !*filespec) {
4779 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4783 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4784 else outbuf = __rmsexpand_retbuf;
4792 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4793 isunix = is_unix_filespec(filespec);
4795 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4796 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4797 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4798 PerlMem_free(vmsfspec);
4803 filespec = vmsfspec;
4805 /* Unless we are forcing to VMS format, a UNIX input means
4806 * UNIX output, and that requires long names to be used
4808 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4809 opts |= PERL_RMSEXPAND_M_LONG;
4816 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4817 rms_bind_fab_nam(myfab, mynam);
4819 if (defspec && *defspec) {
4821 t_isunix = is_unix_filespec(defspec);
4823 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4824 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4825 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4826 PerlMem_free(tmpfspec);
4827 if (vmsfspec != NULL)
4828 PerlMem_free(vmsfspec);
4835 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4838 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4839 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4840 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4841 esal = PerlMem_malloc(VMS_MAXRSS);
4842 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4844 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4846 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4847 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4850 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4851 outbufl = PerlMem_malloc(VMS_MAXRSS);
4852 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4853 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4855 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4859 #ifdef NAM$M_NO_SHORT_UPCASE
4860 if (decc_efs_case_preserve)
4861 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4864 /* First attempt to parse as an existing file */
4865 retsts = sys$parse(&myfab,0,0);
4866 if (!(retsts & STS$K_SUCCESS)) {
4868 /* Could not find the file, try as syntax only if error is not fatal */
4869 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4870 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4871 retsts = sys$parse(&myfab,0,0);
4872 if (retsts & STS$K_SUCCESS) goto expanded;
4875 /* Still could not parse the file specification */
4876 /*----------------------------------------------*/
4877 sts = rms_free_search_context(&myfab); /* Free search context */
4878 if (out) Safefree(out);
4879 if (tmpfspec != NULL)
4880 PerlMem_free(tmpfspec);
4881 if (vmsfspec != NULL)
4882 PerlMem_free(vmsfspec);
4883 if (outbufl != NULL)
4884 PerlMem_free(outbufl);
4888 set_vaxc_errno(retsts);
4889 if (retsts == RMS$_PRV) set_errno(EACCES);
4890 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4891 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4892 else set_errno(EVMSERR);
4895 retsts = sys$search(&myfab,0,0);
4896 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4897 sts = rms_free_search_context(&myfab); /* Free search context */
4898 if (out) Safefree(out);
4899 if (tmpfspec != NULL)
4900 PerlMem_free(tmpfspec);
4901 if (vmsfspec != NULL)
4902 PerlMem_free(vmsfspec);
4903 if (outbufl != NULL)
4904 PerlMem_free(outbufl);
4908 set_vaxc_errno(retsts);
4909 if (retsts == RMS$_PRV) set_errno(EACCES);
4910 else set_errno(EVMSERR);
4914 /* If the input filespec contained any lowercase characters,
4915 * downcase the result for compatibility with Unix-minded code. */
4917 if (!decc_efs_case_preserve) {
4918 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4919 if (islower(*tbuf)) { haslower = 1; break; }
4922 /* Is a long or a short name expected */
4923 /*------------------------------------*/
4924 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4925 if (rms_nam_rsll(mynam)) {
4927 speclen = rms_nam_rsll(mynam);
4930 tbuf = esal; /* Not esa */
4931 speclen = rms_nam_esll(mynam);
4935 if (rms_nam_rsl(mynam)) {
4937 speclen = rms_nam_rsl(mynam);
4940 tbuf = esa; /* Not esal */
4941 speclen = rms_nam_esl(mynam);
4944 tbuf[speclen] = '\0';
4946 /* Trim off null fields added by $PARSE
4947 * If type > 1 char, must have been specified in original or default spec
4948 * (not true for version; $SEARCH may have added version of existing file).
4950 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4951 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4952 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4953 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4956 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4957 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4959 if (trimver || trimtype) {
4960 if (defspec && *defspec) {
4961 char *defesal = NULL;
4962 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
4963 if (defesal != NULL) {
4964 struct FAB deffab = cc$rms_fab;
4965 rms_setup_nam(defnam);
4967 rms_bind_fab_nam(deffab, defnam);
4971 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4973 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4975 rms_clear_nam_nop(defnam);
4976 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4977 #ifdef NAM$M_NO_SHORT_UPCASE
4978 if (decc_efs_case_preserve)
4979 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4981 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4983 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4986 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4989 PerlMem_free(defesal);
4993 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4994 if (*(rms_nam_verl(mynam)) != '\"')
4995 speclen = rms_nam_verl(mynam) - tbuf;
4998 if (*(rms_nam_ver(mynam)) != '\"')
4999 speclen = rms_nam_ver(mynam) - tbuf;
5003 /* If we didn't already trim version, copy down */
5004 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5005 if (speclen > rms_nam_verl(mynam) - tbuf)
5007 (rms_nam_typel(mynam),
5008 rms_nam_verl(mynam),
5009 speclen - (rms_nam_verl(mynam) - tbuf));
5010 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5013 if (speclen > rms_nam_ver(mynam) - tbuf)
5015 (rms_nam_type(mynam),
5017 speclen - (rms_nam_ver(mynam) - tbuf));
5018 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5023 /* Done with these copies of the input files */
5024 /*-------------------------------------------*/
5025 if (vmsfspec != NULL)
5026 PerlMem_free(vmsfspec);
5027 if (tmpfspec != NULL)
5028 PerlMem_free(tmpfspec);
5030 /* If we just had a directory spec on input, $PARSE "helpfully"
5031 * adds an empty name and type for us */
5032 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5033 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5034 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5035 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5036 speclen = rms_nam_namel(mynam) - tbuf;
5039 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5040 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5041 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5042 speclen = rms_nam_name(mynam) - tbuf;
5045 /* Posix format specifications must have matching quotes */
5046 if (speclen < (VMS_MAXRSS - 1)) {
5047 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5048 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5049 tbuf[speclen] = '\"';
5054 tbuf[speclen] = '\0';
5055 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5057 /* Have we been working with an expanded, but not resultant, spec? */
5058 /* Also, convert back to Unix syntax if necessary. */
5060 if (!rms_nam_rsll(mynam)) {
5062 if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
5063 if (out) Safefree(out);
5067 if (outbufl != NULL)
5068 PerlMem_free(outbufl);
5072 else strcpy(outbuf,esa);
5075 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5076 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5077 if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5078 if (out) Safefree(out);
5082 PerlMem_free(tmpfspec);
5083 if (outbufl != NULL)
5084 PerlMem_free(outbufl);
5087 strcpy(outbuf,tmpfspec);
5088 PerlMem_free(tmpfspec);
5091 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5092 sts = rms_free_search_context(&myfab); /* Free search context */
5096 if (outbufl != NULL)
5097 PerlMem_free(outbufl);
5101 /* External entry points */
5102 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5103 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5104 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5105 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5106 char *Perl_rmsexpand_utf8
5107 (pTHX_ const char *spec, char *buf, const char *def,
5108 unsigned opt, int * fs_utf8, int * dfs_utf8)
5109 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5110 char *Perl_rmsexpand_utf8_ts
5111 (pTHX_ const char *spec, char *buf, const char *def,
5112 unsigned opt, int * fs_utf8, int * dfs_utf8)
5113 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5117 ** The following routines are provided to make life easier when
5118 ** converting among VMS-style and Unix-style directory specifications.
5119 ** All will take input specifications in either VMS or Unix syntax. On
5120 ** failure, all return NULL. If successful, the routines listed below
5121 ** return a pointer to a buffer containing the appropriately
5122 ** reformatted spec (and, therefore, subsequent calls to that routine
5123 ** will clobber the result), while the routines of the same names with
5124 ** a _ts suffix appended will return a pointer to a mallocd string
5125 ** containing the appropriately reformatted spec.
5126 ** In all cases, only explicit syntax is altered; no check is made that
5127 ** the resulting string is valid or that the directory in question
5130 ** fileify_dirspec() - convert a directory spec into the name of the
5131 ** directory file (i.e. what you can stat() to see if it's a dir).
5132 ** The style (VMS or Unix) of the result is the same as the style
5133 ** of the parameter passed in.
5134 ** pathify_dirspec() - convert a directory spec into a path (i.e.
5135 ** what you prepend to a filename to indicate what directory it's in).
5136 ** The style (VMS or Unix) of the result is the same as the style
5137 ** of the parameter passed in.
5138 ** tounixpath() - convert a directory spec into a Unix-style path.
5139 ** tovmspath() - convert a directory spec into a VMS-style path.
5140 ** tounixspec() - convert any file spec into a Unix-style file spec.
5141 ** tovmsspec() - convert any file spec into a VMS-style spec.
5142 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5144 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
5145 ** Permission is given to distribute this code as part of the Perl
5146 ** standard distribution under the terms of the GNU General Public
5147 ** License or the Perl Artistic License. Copies of each may be
5148 ** found in the Perl standard distribution.
5151 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5152 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5154 static char __fileify_retbuf[VMS_MAXRSS];
5155 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5156 char *retspec, *cp1, *cp2, *lastdir;
5157 char *trndir, *vmsdir;
5158 unsigned short int trnlnm_iter_count;
5160 if (utf8_fl != NULL)
5163 if (!dir || !*dir) {
5164 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5166 dirlen = strlen(dir);
5167 while (dirlen && dir[dirlen-1] == '/') --dirlen;
5168 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5169 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5176 if (dirlen > (VMS_MAXRSS - 1)) {
5177 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5180 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5181 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5182 if (!strpbrk(dir+1,"/]>:") &&
5183 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5184 strcpy(trndir,*dir == '/' ? dir + 1: dir);
5185 trnlnm_iter_count = 0;
5186 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
5187 trnlnm_iter_count++;
5188 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5190 dirlen = strlen(trndir);
5193 strncpy(trndir,dir,dirlen);
5194 trndir[dirlen] = '\0';
5197 /* At this point we are done with *dir and use *trndir which is a
5198 * copy that can be modified. *dir must not be modified.
5201 /* If we were handed a rooted logical name or spec, treat it like a
5202 * simple directory, so that
5203 * $ Define myroot dev:[dir.]
5204 * ... do_fileify_dirspec("myroot",buf,1) ...
5205 * does something useful.
5207 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5208 trndir[--dirlen] = '\0';
5209 trndir[dirlen-1] = ']';
5211 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5212 trndir[--dirlen] = '\0';
5213 trndir[dirlen-1] = '>';
5216 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5217 /* If we've got an explicit filename, we can just shuffle the string. */
5218 if (*(cp1+1)) hasfilename = 1;
5219 /* Similarly, we can just back up a level if we've got multiple levels
5220 of explicit directories in a VMS spec which ends with directories. */
5222 for (cp2 = cp1; cp2 > trndir; cp2--) {
5224 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5225 /* fix-me, can not scan EFS file specs backward like this */
5226 *cp2 = *cp1; *cp1 = '\0';
5231 if (*cp2 == '[' || *cp2 == '<') break;
5236 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5237 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5238 cp1 = strpbrk(trndir,"]:>");
5239 if (hasfilename || !cp1) { /* Unix-style path or filename */
5240 if (trndir[0] == '.') {
5241 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5242 PerlMem_free(trndir);
5243 PerlMem_free(vmsdir);
5244 return do_fileify_dirspec("[]",buf,ts,NULL);
5246 else if (trndir[1] == '.' &&
5247 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5248 PerlMem_free(trndir);
5249 PerlMem_free(vmsdir);
5250 return do_fileify_dirspec("[-]",buf,ts,NULL);
5253 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
5254 dirlen -= 1; /* to last element */
5255 lastdir = strrchr(trndir,'/');
5257 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5258 /* If we have "/." or "/..", VMSify it and let the VMS code
5259 * below expand it, rather than repeating the code to handle
5260 * relative components of a filespec here */
5262 if (*(cp1+2) == '.') cp1++;
5263 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5265 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5266 PerlMem_free(trndir);
5267 PerlMem_free(vmsdir);
5270 if (strchr(vmsdir,'/') != NULL) {
5271 /* If do_tovmsspec() returned it, it must have VMS syntax
5272 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5273 * the time to check this here only so we avoid a recursion
5274 * loop; otherwise, gigo.
5276 PerlMem_free(trndir);
5277 PerlMem_free(vmsdir);
5278 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5281 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5282 PerlMem_free(trndir);
5283 PerlMem_free(vmsdir);
5286 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5287 PerlMem_free(trndir);
5288 PerlMem_free(vmsdir);
5292 } while ((cp1 = strstr(cp1,"/.")) != NULL);
5293 lastdir = strrchr(trndir,'/');
5295 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5297 /* Ditto for specs that end in an MFD -- let the VMS code
5298 * figure out whether it's a real device or a rooted logical. */
5300 /* This should not happen any more. Allowing the fake /000000
5301 * in a UNIX pathname causes all sorts of problems when trying
5302 * to run in UNIX emulation. So the VMS to UNIX conversions
5303 * now remove the fake /000000 directories.
5306 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5307 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5308 PerlMem_free(trndir);
5309 PerlMem_free(vmsdir);
5312 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5313 PerlMem_free(trndir);
5314 PerlMem_free(vmsdir);
5317 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5318 PerlMem_free(trndir);
5319 PerlMem_free(vmsdir);
5324 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5325 !(lastdir = cp1 = strrchr(trndir,']')) &&
5326 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5327 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
5330 /* For EFS or ODS-5 look for the last dot */
5331 if (decc_efs_charset) {
5332 cp2 = strrchr(cp1,'.');
5334 if (vms_process_case_tolerant) {
5335 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5336 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5337 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5338 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5339 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5340 (ver || *cp3)))))) {
5341 PerlMem_free(trndir);
5342 PerlMem_free(vmsdir);
5344 set_vaxc_errno(RMS$_DIR);
5349 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5350 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5351 !*(cp2+3) || *(cp2+3) != 'R' ||
5352 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5353 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5354 (ver || *cp3)))))) {
5355 PerlMem_free(trndir);
5356 PerlMem_free(vmsdir);
5358 set_vaxc_errno(RMS$_DIR);
5362 dirlen = cp2 - trndir;
5366 retlen = dirlen + 6;
5367 if (buf) retspec = buf;
5368 else if (ts) Newx(retspec,retlen+1,char);
5369 else retspec = __fileify_retbuf;
5370 memcpy(retspec,trndir,dirlen);
5371 retspec[dirlen] = '\0';
5373 /* We've picked up everything up to the directory file name.
5374 Now just add the type and version, and we're set. */
5375 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5376 strcat(retspec,".dir;1");
5378 strcat(retspec,".DIR;1");
5379 PerlMem_free(trndir);
5380 PerlMem_free(vmsdir);
5383 else { /* VMS-style directory spec */
5385 char *esa, term, *cp;
5386 unsigned long int sts, cmplen, haslower = 0;
5387 unsigned int nam_fnb;
5389 struct FAB dirfab = cc$rms_fab;
5390 rms_setup_nam(savnam);
5391 rms_setup_nam(dirnam);
5393 esa = PerlMem_malloc(VMS_MAXRSS + 1);
5394 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5395 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5396 rms_bind_fab_nam(dirfab, dirnam);
5397 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5398 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5399 #ifdef NAM$M_NO_SHORT_UPCASE
5400 if (decc_efs_case_preserve)
5401 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5404 for (cp = trndir; *cp; cp++)
5405 if (islower(*cp)) { haslower = 1; break; }
5406 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5407 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5408 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5409 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5413 PerlMem_free(trndir);
5414 PerlMem_free(vmsdir);
5416 set_vaxc_errno(dirfab.fab$l_sts);
5422 /* Does the file really exist? */
5423 if (sys$search(&dirfab)& STS$K_SUCCESS) {
5424 /* Yes; fake the fnb bits so we'll check type below */
5425 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5427 else { /* No; just work with potential name */
5428 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5431 fab_sts = dirfab.fab$l_sts;
5432 sts = rms_free_search_context(&dirfab);
5434 PerlMem_free(trndir);
5435 PerlMem_free(vmsdir);
5436 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
5441 esa[rms_nam_esll(dirnam)] = '\0';
5442 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5443 cp1 = strchr(esa,']');
5444 if (!cp1) cp1 = strchr(esa,'>');
5445 if (cp1) { /* Should always be true */
5446 rms_nam_esll(dirnam) -= cp1 - esa - 1;
5447 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5450 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5451 /* Yep; check version while we're at it, if it's there. */
5452 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5453 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5454 /* Something other than .DIR[;1]. Bzzt. */
5455 sts = rms_free_search_context(&dirfab);
5457 PerlMem_free(trndir);
5458 PerlMem_free(vmsdir);
5460 set_vaxc_errno(RMS$_DIR);
5465 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5466 /* They provided at least the name; we added the type, if necessary, */
5467 if (buf) retspec = buf; /* in sys$parse() */
5468 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5469 else retspec = __fileify_retbuf;
5470 strcpy(retspec,esa);
5471 sts = rms_free_search_context(&dirfab);
5472 PerlMem_free(trndir);
5474 PerlMem_free(vmsdir);
5477 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5478 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5480 rms_nam_esll(dirnam) -= 9;
5482 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5483 if (cp1 == NULL) { /* should never happen */
5484 sts = rms_free_search_context(&dirfab);
5485 PerlMem_free(trndir);
5487 PerlMem_free(vmsdir);
5492 retlen = strlen(esa);
5493 cp1 = strrchr(esa,'.');
5494 /* ODS-5 directory specifications can have extra "." in them. */
5495 /* Fix-me, can not scan EFS file specifications backwards */
5496 while (cp1 != NULL) {
5497 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5501 while ((cp1 > esa) && (*cp1 != '.'))
5508 if ((cp1) != NULL) {
5509 /* There's more than one directory in the path. Just roll back. */
5511 if (buf) retspec = buf;
5512 else if (ts) Newx(retspec,retlen+7,char);
5513 else retspec = __fileify_retbuf;
5514 strcpy(retspec,esa);
5517 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5518 /* Go back and expand rooted logical name */
5519 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5520 #ifdef NAM$M_NO_SHORT_UPCASE
5521 if (decc_efs_case_preserve)
5522 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5524 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5525 sts = rms_free_search_context(&dirfab);
5527 PerlMem_free(trndir);
5528 PerlMem_free(vmsdir);
5530 set_vaxc_errno(dirfab.fab$l_sts);
5533 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5534 if (buf) retspec = buf;
5535 else if (ts) Newx(retspec,retlen+16,char);
5536 else retspec = __fileify_retbuf;
5537 cp1 = strstr(esa,"][");
5538 if (!cp1) cp1 = strstr(esa,"]<");
5540 memcpy(retspec,esa,dirlen);
5541 if (!strncmp(cp1+2,"000000]",7)) {
5542 retspec[dirlen-1] = '\0';
5543 /* fix-me Not full ODS-5, just extra dots in directories for now */
5544 cp1 = retspec + dirlen - 1;
5545 while (cp1 > retspec)
5550 if (*(cp1-1) != '^')
5555 if (*cp1 == '.') *cp1 = ']';
5557 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5558 memmove(cp1+1,"000000]",7);
5562 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5563 retspec[retlen] = '\0';
5564 /* Convert last '.' to ']' */
5565 cp1 = retspec+retlen-1;
5566 while (*cp != '[') {
5569 /* Do not trip on extra dots in ODS-5 directories */
5570 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5574 if (*cp1 == '.') *cp1 = ']';
5576 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5577 memmove(cp1+1,"000000]",7);
5581 else { /* This is a top-level dir. Add the MFD to the path. */
5582 if (buf) retspec = buf;
5583 else if (ts) Newx(retspec,retlen+16,char);
5584 else retspec = __fileify_retbuf;
5587 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5588 strcpy(cp2,":[000000]");
5593 sts = rms_free_search_context(&dirfab);
5594 /* We've set up the string up through the filename. Add the
5595 type and version, and we're done. */
5596 strcat(retspec,".DIR;1");
5598 /* $PARSE may have upcased filespec, so convert output to lower
5599 * case if input contained any lowercase characters. */
5600 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5601 PerlMem_free(trndir);
5603 PerlMem_free(vmsdir);
5606 } /* end of do_fileify_dirspec() */
5608 /* External entry points */
5609 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5610 { return do_fileify_dirspec(dir,buf,0,NULL); }
5611 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5612 { return do_fileify_dirspec(dir,buf,1,NULL); }
5613 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5614 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5615 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5616 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5618 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5619 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5621 static char __pathify_retbuf[VMS_MAXRSS];
5622 unsigned long int retlen;
5623 char *retpath, *cp1, *cp2, *trndir;
5624 unsigned short int trnlnm_iter_count;
5627 if (utf8_fl != NULL)
5630 if (!dir || !*dir) {
5631 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5634 trndir = PerlMem_malloc(VMS_MAXRSS);
5635 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5636 if (*dir) strcpy(trndir,dir);
5637 else getcwd(trndir,VMS_MAXRSS - 1);
5639 trnlnm_iter_count = 0;
5640 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5641 && my_trnlnm(trndir,trndir,0)) {
5642 trnlnm_iter_count++;
5643 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5644 trnlen = strlen(trndir);
5646 /* Trap simple rooted lnms, and return lnm:[000000] */
5647 if (!strcmp(trndir+trnlen-2,".]")) {
5648 if (buf) retpath = buf;
5649 else if (ts) Newx(retpath,strlen(dir)+10,char);
5650 else retpath = __pathify_retbuf;
5651 strcpy(retpath,dir);
5652 strcat(retpath,":[000000]");
5653 PerlMem_free(trndir);
5658 /* At this point we do not work with *dir, but the copy in
5659 * *trndir that is modifiable.
5662 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5663 if (*trndir == '.' && (*(trndir+1) == '\0' ||
5664 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5665 retlen = 2 + (*(trndir+1) != '\0');
5667 if ( !(cp1 = strrchr(trndir,'/')) &&
5668 !(cp1 = strrchr(trndir,']')) &&
5669 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5670 if ((cp2 = strchr(cp1,'.')) != NULL &&
5671 (*(cp2-1) != '/' || /* Trailing '.', '..', */
5672 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
5673 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5674 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5677 /* For EFS or ODS-5 look for the last dot */
5678 if (decc_efs_charset) {
5679 cp2 = strrchr(cp1,'.');
5681 if (vms_process_case_tolerant) {
5682 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5683 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5684 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5685 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5686 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5687 (ver || *cp3)))))) {
5688 PerlMem_free(trndir);
5690 set_vaxc_errno(RMS$_DIR);
5695 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5696 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5697 !*(cp2+3) || *(cp2+3) != 'R' ||
5698 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5699 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5700 (ver || *cp3)))))) {
5701 PerlMem_free(trndir);
5703 set_vaxc_errno(RMS$_DIR);
5707 retlen = cp2 - trndir + 1;
5709 else { /* No file type present. Treat the filename as a directory. */
5710 retlen = strlen(trndir) + 1;
5713 if (buf) retpath = buf;
5714 else if (ts) Newx(retpath,retlen+1,char);
5715 else retpath = __pathify_retbuf;
5716 strncpy(retpath, trndir, retlen-1);
5717 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5718 retpath[retlen-1] = '/'; /* with '/', add it. */
5719 retpath[retlen] = '\0';
5721 else retpath[retlen-1] = '\0';
5723 else { /* VMS-style directory spec */
5725 unsigned long int sts, cmplen, haslower;
5726 struct FAB dirfab = cc$rms_fab;
5728 rms_setup_nam(savnam);
5729 rms_setup_nam(dirnam);
5731 /* If we've got an explicit filename, we can just shuffle the string. */
5732 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5733 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
5734 if ((cp2 = strchr(cp1,'.')) != NULL) {
5736 if (vms_process_case_tolerant) {
5737 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5738 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5739 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5740 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5741 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5742 (ver || *cp3)))))) {
5743 PerlMem_free(trndir);
5745 set_vaxc_errno(RMS$_DIR);
5750 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5751 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5752 !*(cp2+3) || *(cp2+3) != 'R' ||
5753 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5754 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5755 (ver || *cp3)))))) {
5756 PerlMem_free(trndir);
5758 set_vaxc_errno(RMS$_DIR);
5763 else { /* No file type, so just draw name into directory part */
5764 for (cp2 = cp1; *cp2; cp2++) ;
5767 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5769 /* We've now got a VMS 'path'; fall through */
5772 dirlen = strlen(trndir);
5773 if (trndir[dirlen-1] == ']' ||
5774 trndir[dirlen-1] == '>' ||
5775 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5776 if (buf) retpath = buf;
5777 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5778 else retpath = __pathify_retbuf;
5779 strcpy(retpath,trndir);
5780 PerlMem_free(trndir);
5783 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5784 esa = PerlMem_malloc(VMS_MAXRSS);
5785 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5786 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5787 rms_bind_fab_nam(dirfab, dirnam);
5788 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5789 #ifdef NAM$M_NO_SHORT_UPCASE
5790 if (decc_efs_case_preserve)
5791 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5794 for (cp = trndir; *cp; cp++)
5795 if (islower(*cp)) { haslower = 1; break; }
5797 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5798 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5799 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5800 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5803 PerlMem_free(trndir);
5806 set_vaxc_errno(dirfab.fab$l_sts);
5812 /* Does the file really exist? */
5813 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5814 if (dirfab.fab$l_sts != RMS$_FNF) {
5816 sts1 = rms_free_search_context(&dirfab);
5817 PerlMem_free(trndir);
5820 set_vaxc_errno(dirfab.fab$l_sts);
5823 dirnam = savnam; /* No; just work with potential name */
5826 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5827 /* Yep; check version while we're at it, if it's there. */
5828 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5829 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5831 /* Something other than .DIR[;1]. Bzzt. */
5832 sts2 = rms_free_search_context(&dirfab);
5833 PerlMem_free(trndir);
5836 set_vaxc_errno(RMS$_DIR);
5840 /* OK, the type was fine. Now pull any file name into the
5842 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5844 cp1 = strrchr(esa,'>');
5845 *(rms_nam_typel(dirnam)) = '>';
5848 *(rms_nam_typel(dirnam) + 1) = '\0';
5849 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5850 if (buf) retpath = buf;
5851 else if (ts) Newx(retpath,retlen,char);
5852 else retpath = __pathify_retbuf;
5853 strcpy(retpath,esa);
5855 sts = rms_free_search_context(&dirfab);
5856 /* $PARSE may have upcased filespec, so convert output to lower
5857 * case if input contained any lowercase characters. */
5858 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5861 PerlMem_free(trndir);
5863 } /* end of do_pathify_dirspec() */
5865 /* External entry points */
5866 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5867 { return do_pathify_dirspec(dir,buf,0,NULL); }
5868 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5869 { return do_pathify_dirspec(dir,buf,1,NULL); }
5870 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5871 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5872 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5873 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5875 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5876 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5878 static char __tounixspec_retbuf[VMS_MAXRSS];
5879 char *dirend, *rslt, *cp1, *cp3, *tmp;
5881 int devlen, dirlen, retlen = VMS_MAXRSS;
5882 int expand = 1; /* guarantee room for leading and trailing slashes */
5883 unsigned short int trnlnm_iter_count;
5885 if (utf8_fl != NULL)
5888 if (spec == NULL) return NULL;
5889 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5890 if (buf) rslt = buf;
5892 Newx(rslt, VMS_MAXRSS, char);
5894 else rslt = __tounixspec_retbuf;
5896 /* New VMS specific format needs translation
5897 * glob passes filenames with trailing '\n' and expects this preserved.
5899 if (decc_posix_compliant_pathnames) {
5900 if (strncmp(spec, "\"^UP^", 5) == 0) {
5906 tunix = PerlMem_malloc(VMS_MAXRSS);
5907 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5908 strcpy(tunix, spec);
5909 tunix_len = strlen(tunix);
5911 if (tunix[tunix_len - 1] == '\n') {
5912 tunix[tunix_len - 1] = '\"';
5913 tunix[tunix_len] = '\0';
5917 uspec = decc$translate_vms(tunix);
5918 PerlMem_free(tunix);
5919 if ((int)uspec > 0) {
5925 /* If we can not translate it, makemaker wants as-is */
5933 cmp_rslt = 0; /* Presume VMS */
5934 cp1 = strchr(spec, '/');
5938 /* Look for EFS ^/ */
5939 if (decc_efs_charset) {
5940 while (cp1 != NULL) {
5943 /* Found illegal VMS, assume UNIX */
5948 cp1 = strchr(cp1, '/');
5952 /* Look for "." and ".." */
5953 if (decc_filename_unix_report) {
5954 if (spec[0] == '.') {
5955 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5959 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5965 /* This is already UNIX or at least nothing VMS understands */
5973 dirend = strrchr(spec,']');
5974 if (dirend == NULL) dirend = strrchr(spec,'>');
5975 if (dirend == NULL) dirend = strchr(spec,':');
5976 if (dirend == NULL) {
5981 /* Special case 1 - sys$posix_root = / */
5982 #if __CRTL_VER >= 70000000
5983 if (!decc_disable_posix_root) {
5984 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5992 /* Special case 2 - Convert NLA0: to /dev/null */
5993 #if __CRTL_VER < 70000000
5994 cmp_rslt = strncmp(spec,"NLA0:", 5);
5996 cmp_rslt = strncmp(spec,"nla0:", 5);
5998 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6000 if (cmp_rslt == 0) {
6001 strcpy(rslt, "/dev/null");
6004 if (spec[6] != '\0') {
6011 /* Also handle special case "SYS$SCRATCH:" */
6012 #if __CRTL_VER < 70000000
6013 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6015 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6017 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6019 tmp = PerlMem_malloc(VMS_MAXRSS);
6020 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6021 if (cmp_rslt == 0) {
6024 islnm = my_trnlnm(tmp, "TMP", 0);
6026 strcpy(rslt, "/tmp");
6029 if (spec[12] != '\0') {
6037 if (*cp2 != '[' && *cp2 != '<') {
6040 else { /* the VMS spec begins with directories */
6042 if (*cp2 == ']' || *cp2 == '>') {
6043 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6047 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6048 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6049 if (ts) Safefree(rslt);
6053 trnlnm_iter_count = 0;
6056 while (*cp3 != ':' && *cp3) cp3++;
6058 if (strchr(cp3,']') != NULL) break;
6059 trnlnm_iter_count++;
6060 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6061 } while (vmstrnenv(tmp,tmp,0,fildev,0));
6063 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6064 retlen = devlen + dirlen;
6065 Renew(rslt,retlen+1+2*expand,char);
6071 *(cp1++) = *(cp3++);
6072 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6074 return NULL; /* No room */
6079 if ((*cp2 == '^')) {
6080 /* EFS file escape, pass the next character as is */
6081 /* Fix me: HEX encoding for UNICODE not implemented */
6084 else if ( *cp2 == '.') {
6085 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6086 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6093 for (; cp2 <= dirend; cp2++) {
6094 if ((*cp2 == '^')) {
6095 /* EFS file escape, pass the next character as is */
6096 /* Fix me: HEX encoding for UNICODE not implemented */
6102 if (*(cp2+1) == '[') cp2++;
6104 else if (*cp2 == ']' || *cp2 == '>') {
6105 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6107 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6109 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6110 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6111 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6112 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6113 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6115 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6116 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6120 else if (*cp2 == '-') {
6121 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6122 while (*cp2 == '-') {
6124 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6126 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6127 if (ts) Safefree(rslt); /* filespecs like */
6128 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
6132 else *(cp1++) = *cp2;
6134 else *(cp1++) = *cp2;
6136 while (*cp2) *(cp1++) = *(cp2++);
6139 /* This still leaves /000000/ when working with a
6140 * VMS device root or concealed root.
6146 ulen = strlen(rslt);
6148 /* Get rid of "000000/ in rooted filespecs */
6150 zeros = strstr(rslt, "/000000/");
6151 if (zeros != NULL) {
6153 mlen = ulen - (zeros - rslt) - 7;
6154 memmove(zeros, &zeros[7], mlen);
6163 } /* end of do_tounixspec() */
6165 /* External entry points */
6166 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6167 { return do_tounixspec(spec,buf,0, NULL); }
6168 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6169 { return do_tounixspec(spec,buf,1, NULL); }
6170 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6171 { return do_tounixspec(spec,buf,0, utf8_fl); }
6172 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6173 { return do_tounixspec(spec,buf,1, utf8_fl); }
6175 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6178 This procedure is used to identify if a path is based in either
6179 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6180 it returns the OpenVMS format directory for it.
6182 It is expecting specifications of only '/' or '/xxxx/'
6184 If a posix root does not exist, or 'xxxx' is not a directory
6185 in the posix root, it returns a failure.
6187 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6189 It is used only internally by posix_to_vmsspec_hardway().
6192 static int posix_root_to_vms
6193 (char *vmspath, int vmspath_len,
6194 const char *unixpath,
6195 const int * utf8_fl) {
6197 struct FAB myfab = cc$rms_fab;
6198 struct NAML mynam = cc$rms_naml;
6199 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6200 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6207 unixlen = strlen(unixpath);
6213 #if __CRTL_VER >= 80200000
6214 /* If not a posix spec already, convert it */
6215 if (decc_posix_compliant_pathnames) {
6216 if (strncmp(unixpath,"\"^UP^",5) != 0) {
6217 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6220 /* This is already a VMS specification, no conversion */
6222 strncpy(vmspath,unixpath, vmspath_len);
6231 /* Check to see if this is under the POSIX root */
6232 if (decc_disable_posix_root) {
6236 /* Skip leading / */
6237 if (unixpath[0] == '/') {
6243 strcpy(vmspath,"SYS$POSIX_ROOT:");
6245 /* If this is only the / , or blank, then... */
6246 if (unixpath[0] == '\0') {
6247 /* by definition, this is the answer */
6251 /* Need to look up a directory */
6255 /* Copy and add '^' escape characters as needed */
6258 while (unixpath[i] != 0) {
6261 j += copy_expand_unix_filename_escape
6262 (&vmspath[j], &unixpath[i], &k, utf8_fl);
6266 path_len = strlen(vmspath);
6267 if (vmspath[path_len - 1] == '/')
6269 vmspath[path_len] = ']';
6271 vmspath[path_len] = '\0';
6274 vmspath[vmspath_len] = 0;
6275 if (unixpath[unixlen - 1] == '/')
6277 esa = PerlMem_malloc(VMS_MAXRSS);
6278 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6279 myfab.fab$l_fna = vmspath;
6280 myfab.fab$b_fns = strlen(vmspath);
6281 myfab.fab$l_naml = &mynam;
6282 mynam.naml$l_esa = NULL;
6283 mynam.naml$b_ess = 0;
6284 mynam.naml$l_long_expand = esa;
6285 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6286 mynam.naml$l_rsa = NULL;
6287 mynam.naml$b_rss = 0;
6288 if (decc_efs_case_preserve)
6289 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6290 #ifdef NAML$M_OPEN_SPECIAL
6291 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6294 /* Set up the remaining naml fields */
6295 sts = sys$parse(&myfab);
6297 /* It failed! Try again as a UNIX filespec */
6303 /* get the Device ID and the FID */
6304 sts = sys$search(&myfab);
6305 /* on any failure, returned the POSIX ^UP^ filespec */
6310 specdsc.dsc$a_pointer = vmspath;
6311 specdsc.dsc$w_length = vmspath_len;
6313 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6314 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6315 sts = lib$fid_to_name
6316 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6318 /* on any failure, returned the POSIX ^UP^ filespec */
6320 /* This can happen if user does not have permission to read directories */
6321 if (strncmp(unixpath,"\"^UP^",5) != 0)
6322 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6324 strcpy(vmspath, unixpath);
6327 vmspath[specdsc.dsc$w_length] = 0;
6329 /* Are we expecting a directory? */
6330 if (dir_flag != 0) {
6336 i = specdsc.dsc$w_length - 1;
6340 /* Version must be '1' */
6341 if (vmspath[i--] != '1')
6343 /* Version delimiter is one of ".;" */
6344 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6347 if (vmspath[i--] != 'R')
6349 if (vmspath[i--] != 'I')
6351 if (vmspath[i--] != 'D')
6353 if (vmspath[i--] != '.')
6355 eptr = &vmspath[i+1];
6357 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6358 if (vmspath[i-1] != '^') {
6366 /* Get rid of 6 imaginary zero directory filename */
6367 vmspath[i+1] = '\0';
6371 if (vmspath[i] == '0')
6385 /* /dev/mumble needs to be handled special.
6386 /dev/null becomes NLA0:, And there is the potential for other stuff
6387 like /dev/tty which may need to be mapped to something.
6391 slash_dev_special_to_vms
6392 (const char * unixptr,
6402 nextslash = strchr(unixptr, '/');
6403 len = strlen(unixptr);
6404 if (nextslash != NULL)
6405 len = nextslash - unixptr;
6406 cmp = strncmp("null", unixptr, 5);
6408 if (vmspath_len >= 6) {
6409 strcpy(vmspath, "_NLA0:");
6416 /* The built in routines do not understand perl's special needs, so
6417 doing a manual conversion from UNIX to VMS
6419 If the utf8_fl is not null and points to a non-zero value, then
6420 treat 8 bit characters as UTF-8.
6422 The sequence starting with '$(' and ending with ')' will be passed
6423 through with out interpretation instead of being escaped.
6426 static int posix_to_vmsspec_hardway
6427 (char *vmspath, int vmspath_len,
6428 const char *unixpath,
6433 const char *unixptr;
6434 const char *unixend;
6436 const char *lastslash;
6437 const char *lastdot;
6443 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6444 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6446 if (utf8_fl != NULL)
6452 /* Ignore leading "/" characters */
6453 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6456 unixlen = strlen(unixptr);
6458 /* Do nothing with blank paths */
6465 /* This could have a "^UP^ on the front */
6466 if (strncmp(unixptr,"\"^UP^",5) == 0) {
6472 lastslash = strrchr(unixptr,'/');
6473 lastdot = strrchr(unixptr,'.');
6474 unixend = strrchr(unixptr,'\"');
6475 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6476 unixend = unixptr + unixlen;
6479 /* last dot is last dot or past end of string */
6480 if (lastdot == NULL)
6481 lastdot = unixptr + unixlen;
6483 /* if no directories, set last slash to beginning of string */
6484 if (lastslash == NULL) {
6485 lastslash = unixptr;
6488 /* Watch out for trailing "." after last slash, still a directory */
6489 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6490 lastslash = unixptr + unixlen;
6493 /* Watch out for traiing ".." after last slash, still a directory */
6494 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6495 lastslash = unixptr + unixlen;
6498 /* dots in directories are aways escaped */
6499 if (lastdot < lastslash)
6500 lastdot = unixptr + unixlen;
6503 /* if (unixptr < lastslash) then we are in a directory */
6510 /* Start with the UNIX path */
6511 if (*unixptr != '/') {
6512 /* relative paths */
6514 /* If allowing logical names on relative pathnames, then handle here */
6515 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6516 !decc_posix_compliant_pathnames) {
6522 /* Find the next slash */
6523 nextslash = strchr(unixptr,'/');
6525 esa = PerlMem_malloc(vmspath_len);
6526 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6528 trn = PerlMem_malloc(VMS_MAXRSS);
6529 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6531 if (nextslash != NULL) {
6533 seg_len = nextslash - unixptr;
6534 strncpy(esa, unixptr, seg_len);
6538 strcpy(esa, unixptr);
6539 seg_len = strlen(unixptr);
6541 /* trnlnm(section) */
6542 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6545 /* Now fix up the directory */
6547 /* Split up the path to find the components */
6548 sts = vms_split_path
6567 /* A logical name must be a directory or the full
6568 specification. It is only a full specification if
6569 it is the only component */
6570 if ((unixptr[seg_len] == '\0') ||
6571 (unixptr[seg_len+1] == '\0')) {
6573 /* Is a directory being required? */
6574 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6575 /* Not a logical name */
6580 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6581 /* This must be a directory */
6582 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6583 strcpy(vmsptr, esa);
6584 vmslen=strlen(vmsptr);
6585 vmsptr[vmslen] = ':';
6587 vmsptr[vmslen] = '\0';
6595 /* must be dev/directory - ignore version */
6596 if ((n_len + e_len) != 0)
6599 /* transfer the volume */
6600 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6601 strncpy(vmsptr, v_spec, v_len);
6607 /* unroot the rooted directory */
6608 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6610 r_spec[r_len - 1] = ']';
6612 /* This should not be there, but nothing is perfect */
6614 cmp = strcmp(&r_spec[1], "000000.");
6624 strncpy(vmsptr, r_spec, r_len);
6630 /* Bring over the directory. */
6632 ((d_len + vmslen) < vmspath_len)) {
6634 d_spec[d_len - 1] = ']';
6636 cmp = strcmp(&d_spec[1], "000000.");
6647 /* Remove the redundant root */
6655 strncpy(vmsptr, d_spec, d_len);
6669 if (lastslash > unixptr) {
6672 /* skip leading ./ */
6674 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6680 /* Are we still in a directory? */
6681 if (unixptr <= lastslash) {
6686 /* if not backing up, then it is relative forward. */
6687 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6688 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6696 /* Perl wants an empty directory here to tell the difference
6697 * between a DCL commmand and a filename
6706 /* Handle two special files . and .. */
6707 if (unixptr[0] == '.') {
6708 if (&unixptr[1] == unixend) {
6715 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6726 else { /* Absolute PATH handling */
6730 /* Need to find out where root is */
6732 /* In theory, this procedure should never get an absolute POSIX pathname
6733 * that can not be found on the POSIX root.
6734 * In practice, that can not be relied on, and things will show up
6735 * here that are a VMS device name or concealed logical name instead.
6736 * So to make things work, this procedure must be tolerant.
6738 esa = PerlMem_malloc(vmspath_len);
6739 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6742 nextslash = strchr(&unixptr[1],'/');
6744 if (nextslash != NULL) {
6746 seg_len = nextslash - &unixptr[1];
6747 strncpy(vmspath, unixptr, seg_len + 1);
6748 vmspath[seg_len+1] = 0;
6751 cmp = strncmp(vmspath, "dev", 4);
6753 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6754 if (sts = SS$_NORMAL)
6758 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6761 if ($VMS_STATUS_SUCCESS(sts)) {
6762 /* This is verified to be a real path */
6764 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6765 if ($VMS_STATUS_SUCCESS(sts)) {
6766 strcpy(vmspath, esa);
6767 vmslen = strlen(vmspath);
6768 vmsptr = vmspath + vmslen;
6770 if (unixptr < lastslash) {
6779 cmp = strcmp(rptr,"000000.");
6784 } /* removing 6 zeros */
6785 } /* vmslen < 7, no 6 zeros possible */
6786 } /* Not in a directory */
6787 } /* Posix root found */
6789 /* No posix root, fall back to default directory */
6790 strcpy(vmspath, "SYS$DISK:[");
6791 vmsptr = &vmspath[10];
6793 if (unixptr > lastslash) {
6802 } /* end of verified real path handling */
6807 /* Ok, we have a device or a concealed root that is not in POSIX
6808 * or we have garbage. Make the best of it.
6811 /* Posix to VMS destroyed this, so copy it again */
6812 strncpy(vmspath, &unixptr[1], seg_len);
6813 vmspath[seg_len] = 0;
6815 vmsptr = &vmsptr[vmslen];
6818 /* Now do we need to add the fake 6 zero directory to it? */
6820 if ((*lastslash == '/') && (nextslash < lastslash)) {
6821 /* No there is another directory */
6828 /* now we have foo:bar or foo:[000000]bar to decide from */
6829 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6831 if (!islnm && !decc_posix_compliant_pathnames) {
6833 cmp = strncmp("bin", vmspath, 4);
6835 /* bin => SYS$SYSTEM: */
6836 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6839 /* tmp => SYS$SCRATCH: */
6840 cmp = strncmp("tmp", vmspath, 4);
6842 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6847 trnend = islnm ? islnm - 1 : 0;
6849 /* if this was a logical name, ']' or '>' must be present */
6850 /* if not a logical name, then assume a device and hope. */
6851 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6853 /* if log name and trailing '.' then rooted - treat as device */
6854 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6856 /* Fix me, if not a logical name, a device lookup should be
6857 * done to see if the device is file structured. If the device
6858 * is not file structured, the 6 zeros should not be put on.
6860 * As it is, perl is occasionally looking for dev:[000000]tty.
6861 * which looks a little strange.
6863 * Not that easy to detect as "/dev" may be file structured with
6864 * special device files.
6867 if ((add_6zero == 0) && (*nextslash == '/') &&
6868 (&nextslash[1] == unixend)) {
6869 /* No real directory present */
6874 /* Put the device delimiter on */
6877 unixptr = nextslash;
6880 /* Start directory if needed */
6881 if (!islnm || add_6zero) {
6887 /* add fake 000000] if needed */
6900 } /* non-POSIX translation */
6902 } /* End of relative/absolute path handling */
6904 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6911 if (dir_start != 0) {
6913 /* First characters in a directory are handled special */
6914 while ((*unixptr == '/') ||
6915 ((*unixptr == '.') &&
6916 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6917 (&unixptr[1]==unixend)))) {
6922 /* Skip redundant / in specification */
6923 while ((*unixptr == '/') && (dir_start != 0)) {
6926 if (unixptr == lastslash)
6929 if (unixptr == lastslash)
6932 /* Skip redundant ./ characters */
6933 while ((*unixptr == '.') &&
6934 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6937 if (unixptr == lastslash)
6939 if (*unixptr == '/')
6942 if (unixptr == lastslash)
6945 /* Skip redundant ../ characters */
6946 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6947 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6948 /* Set the backing up flag */
6954 unixptr++; /* first . */
6955 unixptr++; /* second . */
6956 if (unixptr == lastslash)
6958 if (*unixptr == '/') /* The slash */
6961 if (unixptr == lastslash)
6964 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6965 /* Not needed when VMS is pretending to be UNIX. */
6967 /* Is this loop stuck because of too many dots? */
6968 if (loop_flag == 0) {
6969 /* Exit the loop and pass the rest through */
6974 /* Are we done with directories yet? */
6975 if (unixptr >= lastslash) {
6977 /* Watch out for trailing dots */
6986 if (*unixptr == '/')
6990 /* Have we stopped backing up? */
6995 /* dir_start continues to be = 1 */
6997 if (*unixptr == '-') {
6999 *vmsptr++ = *unixptr++;
7003 /* Now are we done with directories yet? */
7004 if (unixptr >= lastslash) {
7006 /* Watch out for trailing dots */
7022 if (unixptr >= unixend)
7025 /* Normal characters - More EFS work probably needed */
7031 /* remove multiple / */
7032 while (unixptr[1] == '/') {
7035 if (unixptr == lastslash) {
7036 /* Watch out for trailing dots */
7048 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7049 /* Not needed when VMS is pretending to be UNIX. */
7053 if (unixptr != unixend)
7058 if ((unixptr < lastdot) || (unixptr < lastslash) ||
7059 (&unixptr[1] == unixend)) {
7065 /* trailing dot ==> '^..' on VMS */
7066 if (unixptr == unixend) {
7074 *vmsptr++ = *unixptr++;
7078 if (quoted && (&unixptr[1] == unixend)) {
7082 in_cnt = copy_expand_unix_filename_escape
7083 (vmsptr, unixptr, &out_cnt, utf8_fl);
7093 in_cnt = copy_expand_unix_filename_escape
7094 (vmsptr, unixptr, &out_cnt, utf8_fl);
7101 /* Make sure directory is closed */
7102 if (unixptr == lastslash) {
7104 vmsptr2 = vmsptr - 1;
7106 if (*vmsptr2 != ']') {
7109 /* directories do not end in a dot bracket */
7110 if (*vmsptr2 == '.') {
7114 if (*vmsptr2 != '^') {
7115 vmsptr--; /* back up over the dot */
7123 /* Add a trailing dot if a file with no extension */
7124 vmsptr2 = vmsptr - 1;
7126 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7127 (*vmsptr2 != ')') && (*lastdot != '.')) {
7138 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7139 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7144 /* If a UTF8 flag is being passed, honor it */
7146 if (utf8_fl != NULL) {
7147 utf8_flag = *utf8_fl;
7152 /* If there is a possibility of UTF8, then if any UTF8 characters
7153 are present, then they must be converted to VTF-7
7155 result = strcpy(rslt, path); /* FIX-ME */
7158 result = strcpy(rslt, path);
7164 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7165 static char *mp_do_tovmsspec
7166 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7167 static char __tovmsspec_retbuf[VMS_MAXRSS];
7168 char *rslt, *dirend;
7173 unsigned long int infront = 0, hasdir = 1;
7176 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7177 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7179 if (path == NULL) return NULL;
7180 rslt_len = VMS_MAXRSS-1;
7181 if (buf) rslt = buf;
7182 else if (ts) Newx(rslt, VMS_MAXRSS, char);
7183 else rslt = __tovmsspec_retbuf;
7185 /* '.' and '..' are "[]" and "[-]" for a quick check */
7186 if (path[0] == '.') {
7187 if (path[1] == '\0') {
7189 if (utf8_flag != NULL)
7194 if (path[1] == '.' && path[2] == '\0') {
7196 if (utf8_flag != NULL)
7203 /* Posix specifications are now a native VMS format */
7204 /*--------------------------------------------------*/
7205 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7206 if (decc_posix_compliant_pathnames) {
7207 if (strncmp(path,"\"^UP^",5) == 0) {
7208 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7214 /* This is really the only way to see if this is already in VMS format */
7215 sts = vms_split_path
7230 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7231 replacement, because the above parse just took care of most of
7232 what is needed to do vmspath when the specification is already
7235 And if it is not already, it is easier to do the conversion as
7236 part of this routine than to call this routine and then work on
7240 /* If VMS punctuation was found, it is already VMS format */
7241 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7242 if (utf8_flag != NULL)
7247 /* Now, what to do with trailing "." cases where there is no
7248 extension? If this is a UNIX specification, and EFS characters
7249 are enabled, then the trailing "." should be converted to a "^.".
7250 But if this was already a VMS specification, then it should be
7253 So in the case of ambiguity, leave the specification alone.
7257 /* If there is a possibility of UTF8, then if any UTF8 characters
7258 are present, then they must be converted to VTF-7
7260 if (utf8_flag != NULL)
7266 dirend = strrchr(path,'/');
7268 if (dirend == NULL) {
7269 /* If we get here with no UNIX directory delimiters, then this is
7270 not a complete file specification, either garbage a UNIX glob
7271 specification that can not be converted to a VMS wildcard, or
7272 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7273 so apparently other programs expect this also.
7275 utf8 flag setting needs to be preserved.
7281 /* If POSIX mode active, handle the conversion */
7282 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7283 if (decc_efs_charset) {
7284 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7289 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
7290 if (!*(dirend+2)) dirend +=2;
7291 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7292 if (decc_efs_charset == 0) {
7293 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7299 lastdot = strrchr(cp2,'.');
7305 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7307 if (decc_disable_posix_root) {
7308 strcpy(rslt,"sys$disk:[000000]");
7311 strcpy(rslt,"sys$posix_root:[000000]");
7313 if (utf8_flag != NULL)
7317 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7319 trndev = PerlMem_malloc(VMS_MAXRSS);
7320 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7321 islnm = my_trnlnm(rslt,trndev,0);
7323 /* DECC special handling */
7325 if (strcmp(rslt,"bin") == 0) {
7326 strcpy(rslt,"sys$system");
7329 islnm = my_trnlnm(rslt,trndev,0);
7331 else if (strcmp(rslt,"tmp") == 0) {
7332 strcpy(rslt,"sys$scratch");
7335 islnm = my_trnlnm(rslt,trndev,0);
7337 else if (!decc_disable_posix_root) {
7338 strcpy(rslt, "sys$posix_root");
7342 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7343 islnm = my_trnlnm(rslt,trndev,0);
7345 else if (strcmp(rslt,"dev") == 0) {
7346 if (strncmp(cp2,"/null", 5) == 0) {
7347 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7348 strcpy(rslt,"NLA0");
7352 islnm = my_trnlnm(rslt,trndev,0);
7358 trnend = islnm ? strlen(trndev) - 1 : 0;
7359 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7360 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7361 /* If the first element of the path is a logical name, determine
7362 * whether it has to be translated so we can add more directories. */
7363 if (!islnm || rooted) {
7366 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7370 if (cp2 != dirend) {
7371 strcpy(rslt,trndev);
7372 cp1 = rslt + trnend;
7379 if (decc_disable_posix_root) {
7385 PerlMem_free(trndev);
7390 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7391 cp2 += 2; /* skip over "./" - it's redundant */
7392 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
7394 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7395 *(cp1++) = '-'; /* "../" --> "-" */
7398 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7399 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7400 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7401 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7404 else if ((cp2 != lastdot) || (lastdot < dirend)) {
7405 /* Escape the extra dots in EFS file specifications */
7408 if (cp2 > dirend) cp2 = dirend;
7410 else *(cp1++) = '.';
7412 for (; cp2 < dirend; cp2++) {
7414 if (*(cp2-1) == '/') continue;
7415 if (*(cp1-1) != '.') *(cp1++) = '.';
7418 else if (!infront && *cp2 == '.') {
7419 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7420 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
7421 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7422 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7423 else if (*(cp1-2) == '[') *(cp1-1) = '-';
7424 else { /* back up over previous directory name */
7426 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7427 if (*(cp1-1) == '[') {
7428 memcpy(cp1,"000000.",7);
7433 if (cp2 == dirend) break;
7435 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7436 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7437 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7438 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7440 *(cp1++) = '.'; /* Simulate trailing '/' */
7441 cp2 += 2; /* for loop will incr this to == dirend */
7443 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
7446 if (decc_efs_charset == 0)
7447 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
7449 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
7455 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
7457 if (decc_efs_charset == 0)
7464 else *(cp1++) = *cp2;
7468 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7469 if (hasdir) *(cp1++) = ']';
7470 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
7471 /* fixme for ODS5 */
7478 if (decc_efs_charset == 0)
7489 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7490 decc_readdir_dropdotnotype) {
7495 /* trailing dot ==> '^..' on VMS */
7502 *(cp1++) = *(cp2++);
7507 /* This could be a macro to be passed through */
7508 *(cp1++) = *(cp2++);
7510 const char * save_cp2;
7514 /* paranoid check */
7520 *(cp1++) = *(cp2++);
7521 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7522 *(cp1++) = *(cp2++);
7523 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7524 *(cp1++) = *(cp2++);
7527 *(cp1++) = *(cp2++);
7531 if (is_macro == 0) {
7532 /* Not really a macro - never mind */
7562 *(cp1++) = *(cp2++);
7565 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7566 * which is wrong. UNIX notation should be ".dir." unless
7567 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7568 * changing this behavior could break more things at this time.
7569 * efs character set effectively does not allow "." to be a version
7570 * delimiter as a further complication about changing this.
7572 if (decc_filename_unix_report != 0) {
7575 *(cp1++) = *(cp2++);
7578 *(cp1++) = *(cp2++);
7581 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7585 /* Fix me for "^]", but that requires making sure that you do
7586 * not back up past the start of the filename
7588 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7593 if (utf8_flag != NULL)
7597 } /* end of do_tovmsspec() */
7599 /* External entry points */
7600 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7601 { return do_tovmsspec(path,buf,0,NULL); }
7602 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7603 { return do_tovmsspec(path,buf,1,NULL); }
7604 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7605 { return do_tovmsspec(path,buf,0,utf8_fl); }
7606 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7607 { return do_tovmsspec(path,buf,1,utf8_fl); }
7609 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7610 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7611 static char __tovmspath_retbuf[VMS_MAXRSS];
7613 char *pathified, *vmsified, *cp;
7615 if (path == NULL) return NULL;
7616 pathified = PerlMem_malloc(VMS_MAXRSS);
7617 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7618 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7619 PerlMem_free(pathified);
7625 Newx(vmsified, VMS_MAXRSS, char);
7626 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7627 PerlMem_free(pathified);
7628 if (vmsified) Safefree(vmsified);
7631 PerlMem_free(pathified);
7636 vmslen = strlen(vmsified);
7637 Newx(cp,vmslen+1,char);
7638 memcpy(cp,vmsified,vmslen);
7644 strcpy(__tovmspath_retbuf,vmsified);
7646 return __tovmspath_retbuf;
7649 } /* end of do_tovmspath() */
7651 /* External entry points */
7652 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7653 { return do_tovmspath(path,buf,0, NULL); }
7654 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7655 { return do_tovmspath(path,buf,1, NULL); }
7656 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7657 { return do_tovmspath(path,buf,0,utf8_fl); }
7658 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7659 { return do_tovmspath(path,buf,1,utf8_fl); }
7662 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7663 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7664 static char __tounixpath_retbuf[VMS_MAXRSS];
7666 char *pathified, *unixified, *cp;
7668 if (path == NULL) return NULL;
7669 pathified = PerlMem_malloc(VMS_MAXRSS);
7670 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7671 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7672 PerlMem_free(pathified);
7678 Newx(unixified, VMS_MAXRSS, char);
7680 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7681 PerlMem_free(pathified);
7682 if (unixified) Safefree(unixified);
7685 PerlMem_free(pathified);
7690 unixlen = strlen(unixified);
7691 Newx(cp,unixlen+1,char);
7692 memcpy(cp,unixified,unixlen);
7694 Safefree(unixified);
7698 strcpy(__tounixpath_retbuf,unixified);
7699 Safefree(unixified);
7700 return __tounixpath_retbuf;
7703 } /* end of do_tounixpath() */
7705 /* External entry points */
7706 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7707 { return do_tounixpath(path,buf,0,NULL); }
7708 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7709 { return do_tounixpath(path,buf,1,NULL); }
7710 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7711 { return do_tounixpath(path,buf,0,utf8_fl); }
7712 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7713 { return do_tounixpath(path,buf,1,utf8_fl); }
7716 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
7718 *****************************************************************************
7720 * Copyright (C) 1989-1994 by *
7721 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
7723 * Permission is hereby granted for the reproduction of this software, *
7724 * on condition that this copyright notice is included in the reproduction, *
7725 * and that such reproduction is not for purposes of profit or material *
7728 * 27-Aug-1994 Modified for inclusion in perl5 *
7729 * by Charles Bailey bailey@newman.upenn.edu *
7730 *****************************************************************************
7734 * getredirection() is intended to aid in porting C programs
7735 * to VMS (Vax-11 C). The native VMS environment does not support
7736 * '>' and '<' I/O redirection, or command line wild card expansion,
7737 * or a command line pipe mechanism using the '|' AND background
7738 * command execution '&'. All of these capabilities are provided to any
7739 * C program which calls this procedure as the first thing in the
7741 * The piping mechanism will probably work with almost any 'filter' type
7742 * of program. With suitable modification, it may useful for other
7743 * portability problems as well.
7745 * Author: Mark Pizzolato mark@infocomm.com
7749 struct list_item *next;
7753 static void add_item(struct list_item **head,
7754 struct list_item **tail,
7758 static void mp_expand_wild_cards(pTHX_ char *item,
7759 struct list_item **head,
7760 struct list_item **tail,
7763 static int background_process(pTHX_ int argc, char **argv);
7765 static void pipe_and_fork(pTHX_ char **cmargv);
7767 /*{{{ void getredirection(int *ac, char ***av)*/
7769 mp_getredirection(pTHX_ int *ac, char ***av)
7771 * Process vms redirection arg's. Exit if any error is seen.
7772 * If getredirection() processes an argument, it is erased
7773 * from the vector. getredirection() returns a new argc and argv value.
7774 * In the event that a background command is requested (by a trailing "&"),
7775 * this routine creates a background subprocess, and simply exits the program.
7777 * Warning: do not try to simplify the code for vms. The code
7778 * presupposes that getredirection() is called before any data is
7779 * read from stdin or written to stdout.
7781 * Normal usage is as follows:
7787 * getredirection(&argc, &argv);
7791 int argc = *ac; /* Argument Count */
7792 char **argv = *av; /* Argument Vector */
7793 char *ap; /* Argument pointer */
7794 int j; /* argv[] index */
7795 int item_count = 0; /* Count of Items in List */
7796 struct list_item *list_head = 0; /* First Item in List */
7797 struct list_item *list_tail; /* Last Item in List */
7798 char *in = NULL; /* Input File Name */
7799 char *out = NULL; /* Output File Name */
7800 char *outmode = "w"; /* Mode to Open Output File */
7801 char *err = NULL; /* Error File Name */
7802 char *errmode = "w"; /* Mode to Open Error File */
7803 int cmargc = 0; /* Piped Command Arg Count */
7804 char **cmargv = NULL;/* Piped Command Arg Vector */
7807 * First handle the case where the last thing on the line ends with
7808 * a '&'. This indicates the desire for the command to be run in a
7809 * subprocess, so we satisfy that desire.
7812 if (0 == strcmp("&", ap))
7813 exit(background_process(aTHX_ --argc, argv));
7814 if (*ap && '&' == ap[strlen(ap)-1])
7816 ap[strlen(ap)-1] = '\0';
7817 exit(background_process(aTHX_ argc, argv));
7820 * Now we handle the general redirection cases that involve '>', '>>',
7821 * '<', and pipes '|'.
7823 for (j = 0; j < argc; ++j)
7825 if (0 == strcmp("<", argv[j]))
7829 fprintf(stderr,"No input file after < on command line");
7830 exit(LIB$_WRONUMARG);
7835 if ('<' == *(ap = argv[j]))
7840 if (0 == strcmp(">", ap))
7844 fprintf(stderr,"No output file after > on command line");
7845 exit(LIB$_WRONUMARG);
7864 fprintf(stderr,"No output file after > or >> on command line");
7865 exit(LIB$_WRONUMARG);
7869 if (('2' == *ap) && ('>' == ap[1]))
7886 fprintf(stderr,"No output file after 2> or 2>> on command line");
7887 exit(LIB$_WRONUMARG);
7891 if (0 == strcmp("|", argv[j]))
7895 fprintf(stderr,"No command into which to pipe on command line");
7896 exit(LIB$_WRONUMARG);
7898 cmargc = argc-(j+1);
7899 cmargv = &argv[j+1];
7903 if ('|' == *(ap = argv[j]))
7911 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7914 * Allocate and fill in the new argument vector, Some Unix's terminate
7915 * the list with an extra null pointer.
7917 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7918 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7920 for (j = 0; j < item_count; ++j, list_head = list_head->next)
7921 argv[j] = list_head->value;
7927 fprintf(stderr,"'|' and '>' may not both be specified on command line");
7928 exit(LIB$_INVARGORD);
7930 pipe_and_fork(aTHX_ cmargv);
7933 /* Check for input from a pipe (mailbox) */
7935 if (in == NULL && 1 == isapipe(0))
7937 char mbxname[L_tmpnam];
7939 long int dvi_item = DVI$_DEVBUFSIZ;
7940 $DESCRIPTOR(mbxnam, "");
7941 $DESCRIPTOR(mbxdevnam, "");
7943 /* Input from a pipe, reopen it in binary mode to disable */
7944 /* carriage control processing. */
7946 fgetname(stdin, mbxname);
7947 mbxnam.dsc$a_pointer = mbxname;
7948 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7949 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7950 mbxdevnam.dsc$a_pointer = mbxname;
7951 mbxdevnam.dsc$w_length = sizeof(mbxname);
7952 dvi_item = DVI$_DEVNAM;
7953 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7954 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7957 freopen(mbxname, "rb", stdin);
7960 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7964 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7966 fprintf(stderr,"Can't open input file %s as stdin",in);
7969 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7971 fprintf(stderr,"Can't open output file %s as stdout",out);
7974 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7977 if (strcmp(err,"&1") == 0) {
7978 dup2(fileno(stdout), fileno(stderr));
7979 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7982 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7984 fprintf(stderr,"Can't open error file %s as stderr",err);
7988 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7992 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7995 #ifdef ARGPROC_DEBUG
7996 PerlIO_printf(Perl_debug_log, "Arglist:\n");
7997 for (j = 0; j < *ac; ++j)
7998 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8000 /* Clear errors we may have hit expanding wildcards, so they don't
8001 show up in Perl's $! later */
8002 set_errno(0); set_vaxc_errno(1);
8003 } /* end of getredirection() */
8006 static void add_item(struct list_item **head,
8007 struct list_item **tail,
8013 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8014 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8018 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8019 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8020 *tail = (*tail)->next;
8022 (*tail)->value = value;
8026 static void mp_expand_wild_cards(pTHX_ char *item,
8027 struct list_item **head,
8028 struct list_item **tail,
8032 unsigned long int context = 0;
8040 $DESCRIPTOR(filespec, "");
8041 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8042 $DESCRIPTOR(resultspec, "");
8043 unsigned long int lff_flags = 0;
8047 #ifdef VMS_LONGNAME_SUPPORT
8048 lff_flags = LIB$M_FIL_LONG_NAMES;
8051 for (cp = item; *cp; cp++) {
8052 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8053 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8055 if (!*cp || isspace(*cp))
8057 add_item(head, tail, item, count);
8062 /* "double quoted" wild card expressions pass as is */
8063 /* From DCL that means using e.g.: */
8064 /* perl program """perl.*""" */
8065 item_len = strlen(item);
8066 if ( '"' == *item && '"' == item[item_len-1] )
8069 item[item_len-2] = '\0';
8070 add_item(head, tail, item, count);
8074 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8075 resultspec.dsc$b_class = DSC$K_CLASS_D;
8076 resultspec.dsc$a_pointer = NULL;
8077 vmsspec = PerlMem_malloc(VMS_MAXRSS);
8078 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8079 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8080 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8081 if (!isunix || !filespec.dsc$a_pointer)
8082 filespec.dsc$a_pointer = item;
8083 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8085 * Only return version specs, if the caller specified a version
8087 had_version = strchr(item, ';');
8089 * Only return device and directory specs, if the caller specifed either.
8091 had_device = strchr(item, ':');
8092 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8094 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8095 (&filespec, &resultspec, &context,
8096 &defaultspec, 0, &rms_sts, &lff_flags)))
8101 string = PerlMem_malloc(resultspec.dsc$w_length+1);
8102 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8103 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8104 string[resultspec.dsc$w_length] = '\0';
8105 if (NULL == had_version)
8106 *(strrchr(string, ';')) = '\0';
8107 if ((!had_directory) && (had_device == NULL))
8109 if (NULL == (devdir = strrchr(string, ']')))
8110 devdir = strrchr(string, '>');
8111 strcpy(string, devdir + 1);
8114 * Be consistent with what the C RTL has already done to the rest of
8115 * the argv items and lowercase all of these names.
8117 if (!decc_efs_case_preserve) {
8118 for (c = string; *c; ++c)
8122 if (isunix) trim_unixpath(string,item,1);
8123 add_item(head, tail, string, count);
8126 PerlMem_free(vmsspec);
8127 if (sts != RMS$_NMF)
8129 set_vaxc_errno(sts);
8132 case RMS$_FNF: case RMS$_DNF:
8133 set_errno(ENOENT); break;
8135 set_errno(ENOTDIR); break;
8137 set_errno(ENODEV); break;
8138 case RMS$_FNM: case RMS$_SYN:
8139 set_errno(EINVAL); break;
8141 set_errno(EACCES); break;
8143 _ckvmssts_noperl(sts);
8147 add_item(head, tail, item, count);
8148 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8149 _ckvmssts_noperl(lib$find_file_end(&context));
8152 static int child_st[2];/* Event Flag set when child process completes */
8154 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
8156 static unsigned long int exit_handler(int *status)
8160 if (0 == child_st[0])
8162 #ifdef ARGPROC_DEBUG
8163 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8165 fflush(stdout); /* Have to flush pipe for binary data to */
8166 /* terminate properly -- <tp@mccall.com> */
8167 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8168 sys$dassgn(child_chan);
8170 sys$synch(0, child_st);
8175 static void sig_child(int chan)
8177 #ifdef ARGPROC_DEBUG
8178 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8180 if (child_st[0] == 0)
8184 static struct exit_control_block exit_block =
8189 &exit_block.exit_status,
8194 pipe_and_fork(pTHX_ char **cmargv)
8197 struct dsc$descriptor_s *vmscmd;
8198 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8199 int sts, j, l, ismcr, quote, tquote = 0;
8201 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
8202 vms_execfree(vmscmd);
8207 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
8208 && toupper(*(q+2)) == 'R' && !*(q+3);
8210 while (q && l < MAX_DCL_LINE_LENGTH) {
8212 if (j > 0 && quote) {
8218 if (ismcr && j > 1) quote = 1;
8219 tquote = (strchr(q,' ')) != NULL || *q == '\0';
8222 if (quote || tquote) {
8228 if ((quote||tquote) && *q == '"') {
8238 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8240 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8244 static int background_process(pTHX_ int argc, char **argv)
8246 char command[MAX_DCL_SYMBOL + 1] = "$";
8247 $DESCRIPTOR(value, "");
8248 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8249 static $DESCRIPTOR(null, "NLA0:");
8250 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8252 $DESCRIPTOR(pidstr, "");
8254 unsigned long int flags = 17, one = 1, retsts;
8257 strcat(command, argv[0]);
8258 len = strlen(command);
8259 while (--argc && (len < MAX_DCL_SYMBOL))
8261 strcat(command, " \"");
8262 strcat(command, *(++argv));
8263 strcat(command, "\"");
8264 len = strlen(command);
8266 value.dsc$a_pointer = command;
8267 value.dsc$w_length = strlen(value.dsc$a_pointer);
8268 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8269 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8270 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8271 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8274 _ckvmssts_noperl(retsts);
8276 #ifdef ARGPROC_DEBUG
8277 PerlIO_printf(Perl_debug_log, "%s\n", command);
8279 sprintf(pidstring, "%08X", pid);
8280 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8281 pidstr.dsc$a_pointer = pidstring;
8282 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8283 lib$set_symbol(&pidsymbol, &pidstr);
8287 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8290 /* OS-specific initialization at image activation (not thread startup) */
8291 /* Older VAXC header files lack these constants */
8292 #ifndef JPI$_RIGHTS_SIZE
8293 # define JPI$_RIGHTS_SIZE 817
8295 #ifndef KGB$M_SUBSYSTEM
8296 # define KGB$M_SUBSYSTEM 0x8
8299 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8301 /*{{{void vms_image_init(int *, char ***)*/
8303 vms_image_init(int *argcp, char ***argvp)
8305 char eqv[LNM$C_NAMLENGTH+1] = "";
8306 unsigned int len, tabct = 8, tabidx = 0;
8307 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8308 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8309 unsigned short int dummy, rlen;
8310 struct dsc$descriptor_s **tabvec;
8311 #if defined(PERL_IMPLICIT_CONTEXT)
8314 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8315 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8316 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8319 #ifdef KILL_BY_SIGPRC
8320 Perl_csighandler_init();
8323 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8324 _ckvmssts_noperl(iosb[0]);
8325 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8326 if (iprv[i]) { /* Running image installed with privs? */
8327 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
8332 /* Rights identifiers might trigger tainting as well. */
8333 if (!will_taint && (rlen || rsz)) {
8334 while (rlen < rsz) {
8335 /* We didn't get all the identifiers on the first pass. Allocate a
8336 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8337 * were needed to hold all identifiers at time of last call; we'll
8338 * allocate that many unsigned long ints), and go back and get 'em.
8339 * If it gave us less than it wanted to despite ample buffer space,
8340 * something's broken. Is your system missing a system identifier?
8342 if (rsz <= jpilist[1].buflen) {
8343 /* Perl_croak accvios when used this early in startup. */
8344 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8345 rsz, (unsigned long) jpilist[1].buflen,
8346 "Check your rights database for corruption.\n");
8349 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8350 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8351 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8352 jpilist[1].buflen = rsz * sizeof(unsigned long int);
8353 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8354 _ckvmssts_noperl(iosb[0]);
8356 mask = jpilist[1].bufadr;
8357 /* Check attribute flags for each identifier (2nd longword); protected
8358 * subsystem identifiers trigger tainting.
8360 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8361 if (mask[i] & KGB$M_SUBSYSTEM) {
8366 if (mask != rlst) PerlMem_free(mask);
8369 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8370 * logical, some versions of the CRTL will add a phanthom /000000/
8371 * directory. This needs to be removed.
8373 if (decc_filename_unix_report) {
8376 ulen = strlen(argvp[0][0]);
8378 zeros = strstr(argvp[0][0], "/000000/");
8379 if (zeros != NULL) {
8381 mlen = ulen - (zeros - argvp[0][0]) - 7;
8382 memmove(zeros, &zeros[7], mlen);
8384 argvp[0][0][ulen] = '\0';
8387 /* It also may have a trailing dot that needs to be removed otherwise
8388 * it will be converted to VMS mode incorrectly.
8391 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8392 argvp[0][0][ulen] = '\0';
8395 /* We need to use this hack to tell Perl it should run with tainting,
8396 * since its tainting flag may be part of the PL_curinterp struct, which
8397 * hasn't been allocated when vms_image_init() is called.
8400 char **newargv, **oldargv;
8402 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8403 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8404 newargv[0] = oldargv[0];
8405 newargv[1] = PerlMem_malloc(3 * sizeof(char));
8406 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8407 strcpy(newargv[1], "-T");
8408 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8410 newargv[*argcp] = NULL;
8411 /* We orphan the old argv, since we don't know where it's come from,
8412 * so we don't know how to free it.
8416 else { /* Did user explicitly request tainting? */
8418 char *cp, **av = *argvp;
8419 for (i = 1; i < *argcp; i++) {
8420 if (*av[i] != '-') break;
8421 for (cp = av[i]+1; *cp; cp++) {
8422 if (*cp == 'T') { will_taint = 1; break; }
8423 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8424 strchr("DFIiMmx",*cp)) break;
8426 if (will_taint) break;
8431 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8434 tabvec = (struct dsc$descriptor_s **)
8435 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8436 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8438 else if (tabidx >= tabct) {
8440 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8441 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8443 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8444 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8445 tabvec[tabidx]->dsc$w_length = 0;
8446 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
8447 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
8448 tabvec[tabidx]->dsc$a_pointer = NULL;
8449 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8451 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8453 getredirection(argcp,argvp);
8454 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8456 # include <reentrancy.h>
8457 decc$set_reentrancy(C$C_MULTITHREAD);
8466 * Trim Unix-style prefix off filespec, so it looks like what a shell
8467 * glob expansion would return (i.e. from specified prefix on, not
8468 * full path). Note that returned filespec is Unix-style, regardless
8469 * of whether input filespec was VMS-style or Unix-style.
8471 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8472 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
8473 * vector of options; at present, only bit 0 is used, and if set tells
8474 * trim unixpath to try the current default directory as a prefix when
8475 * presented with a possibly ambiguous ... wildcard.
8477 * Returns !=0 on success, with trimmed filespec replacing contents of
8478 * fspec, and 0 on failure, with contents of fpsec unchanged.
8480 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8482 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8484 char *unixified, *unixwild,
8485 *template, *base, *end, *cp1, *cp2;
8486 register int tmplen, reslen = 0, dirs = 0;
8488 unixwild = PerlMem_malloc(VMS_MAXRSS);
8489 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8490 if (!wildspec || !fspec) return 0;
8491 template = unixwild;
8492 if (strpbrk(wildspec,"]>:") != NULL) {
8493 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8494 PerlMem_free(unixwild);
8499 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8500 unixwild[VMS_MAXRSS-1] = 0;
8502 unixified = PerlMem_malloc(VMS_MAXRSS);
8503 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8504 if (strpbrk(fspec,"]>:") != NULL) {
8505 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8506 PerlMem_free(unixwild);
8507 PerlMem_free(unixified);
8510 else base = unixified;
8511 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8512 * check to see that final result fits into (isn't longer than) fspec */
8513 reslen = strlen(fspec);
8517 /* No prefix or absolute path on wildcard, so nothing to remove */
8518 if (!*template || *template == '/') {
8519 PerlMem_free(unixwild);
8520 if (base == fspec) {
8521 PerlMem_free(unixified);
8524 tmplen = strlen(unixified);
8525 if (tmplen > reslen) {
8526 PerlMem_free(unixified);
8527 return 0; /* not enough space */
8529 /* Copy unixified resultant, including trailing NUL */
8530 memmove(fspec,unixified,tmplen+1);
8531 PerlMem_free(unixified);
8535 for (end = base; *end; end++) ; /* Find end of resultant filespec */
8536 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8537 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8538 for (cp1 = end ;cp1 >= base; cp1--)
8539 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8541 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8542 PerlMem_free(unixified);
8543 PerlMem_free(unixwild);
8548 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8549 int ells = 1, totells, segdirs, match;
8550 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8551 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8553 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8555 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8556 tpl = PerlMem_malloc(VMS_MAXRSS);
8557 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8558 if (ellipsis == template && opts & 1) {
8559 /* Template begins with an ellipsis. Since we can't tell how many
8560 * directory names at the front of the resultant to keep for an
8561 * arbitrary starting point, we arbitrarily choose the current
8562 * default directory as a starting point. If it's there as a prefix,
8563 * clip it off. If not, fall through and act as if the leading
8564 * ellipsis weren't there (i.e. return shortest possible path that
8565 * could match template).
8567 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8569 PerlMem_free(unixified);
8570 PerlMem_free(unixwild);
8573 if (!decc_efs_case_preserve) {
8574 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8575 if (_tolower(*cp1) != _tolower(*cp2)) break;
8577 segdirs = dirs - totells; /* Min # of dirs we must have left */
8578 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8579 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8580 memmove(fspec,cp2+1,end - cp2);
8582 PerlMem_free(unixified);
8583 PerlMem_free(unixwild);
8587 /* First off, back up over constant elements at end of path */
8589 for (front = end ; front >= base; front--)
8590 if (*front == '/' && !dirs--) { front++; break; }
8592 lcres = PerlMem_malloc(VMS_MAXRSS);
8593 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8594 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8596 if (!decc_efs_case_preserve) {
8597 *cp2 = _tolower(*cp1); /* Make lc copy for match */
8605 PerlMem_free(unixified);
8606 PerlMem_free(unixwild);
8607 PerlMem_free(lcres);
8608 return 0; /* Path too long. */
8611 *cp2 = '\0'; /* Pick up with memcpy later */
8612 lcfront = lcres + (front - base);
8613 /* Now skip over each ellipsis and try to match the path in front of it. */
8615 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8616 if (*(cp1) == '.' && *(cp1+1) == '.' &&
8617 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
8618 if (cp1 < template) break; /* template started with an ellipsis */
8619 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8620 ellipsis = cp1; continue;
8622 wilddsc.dsc$a_pointer = tpl;
8623 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8625 for (segdirs = 0, cp2 = tpl;
8626 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8628 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8630 if (!decc_efs_case_preserve) {
8631 *cp2 = _tolower(*cp1); /* else lowercase for match */
8634 *cp2 = *cp1; /* else preserve case for match */
8637 if (*cp2 == '/') segdirs++;
8639 if (cp1 != ellipsis - 1) {
8641 PerlMem_free(unixified);
8642 PerlMem_free(unixwild);
8643 PerlMem_free(lcres);
8644 return 0; /* Path too long */
8646 /* Back up at least as many dirs as in template before matching */
8647 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8648 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8649 for (match = 0; cp1 > lcres;) {
8650 resdsc.dsc$a_pointer = cp1;
8651 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8653 if (match == 1) lcfront = cp1;
8655 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8659 PerlMem_free(unixified);
8660 PerlMem_free(unixwild);
8661 PerlMem_free(lcres);
8662 return 0; /* Can't find prefix ??? */
8664 if (match > 1 && opts & 1) {
8665 /* This ... wildcard could cover more than one set of dirs (i.e.
8666 * a set of similar dir names is repeated). If the template
8667 * contains more than 1 ..., upstream elements could resolve the
8668 * ambiguity, but it's not worth a full backtracking setup here.
8669 * As a quick heuristic, clip off the current default directory
8670 * if it's present to find the trimmed spec, else use the
8671 * shortest string that this ... could cover.
8673 char def[NAM$C_MAXRSS+1], *st;
8675 if (getcwd(def, sizeof def,0) == NULL) {
8676 Safefree(unixified);
8682 if (!decc_efs_case_preserve) {
8683 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8684 if (_tolower(*cp1) != _tolower(*cp2)) break;
8686 segdirs = dirs - totells; /* Min # of dirs we must have left */
8687 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8688 if (*cp1 == '\0' && *cp2 == '/') {
8689 memmove(fspec,cp2+1,end - cp2);
8691 PerlMem_free(unixified);
8692 PerlMem_free(unixwild);
8693 PerlMem_free(lcres);
8696 /* Nope -- stick with lcfront from above and keep going. */
8699 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8701 PerlMem_free(unixified);
8702 PerlMem_free(unixwild);
8703 PerlMem_free(lcres);
8708 } /* end of trim_unixpath() */
8713 * VMS readdir() routines.
8714 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8716 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
8717 * Minor modifications to original routines.
8720 /* readdir may have been redefined by reentr.h, so make sure we get
8721 * the local version for what we do here.
8726 #if !defined(PERL_IMPLICIT_CONTEXT)
8727 # define readdir Perl_readdir
8729 # define readdir(a) Perl_readdir(aTHX_ a)
8732 /* Number of elements in vms_versions array */
8733 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
8736 * Open a directory, return a handle for later use.
8738 /*{{{ DIR *opendir(char*name) */
8740 Perl_opendir(pTHX_ const char *name)
8748 if (decc_efs_charset) {
8749 unix_flag = is_unix_filespec(name);
8752 Newx(dir, VMS_MAXRSS, char);
8753 if (do_tovmspath(name,dir,0,NULL) == NULL) {
8757 /* Check access before stat; otherwise stat does not
8758 * accurately report whether it's a directory.
8760 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8761 /* cando_by_name has already set errno */
8765 if (flex_stat(dir,&sb) == -1) return NULL;
8766 if (!S_ISDIR(sb.st_mode)) {
8768 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
8771 /* Get memory for the handle, and the pattern. */
8773 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8775 /* Fill in the fields; mainly playing with the descriptor. */
8776 sprintf(dd->pattern, "%s*.*",dir);
8782 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8783 dd->pat.dsc$a_pointer = dd->pattern;
8784 dd->pat.dsc$w_length = strlen(dd->pattern);
8785 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8786 dd->pat.dsc$b_class = DSC$K_CLASS_S;
8787 #if defined(USE_ITHREADS)
8788 Newx(dd->mutex,1,perl_mutex);
8789 MUTEX_INIT( (perl_mutex *) dd->mutex );
8795 } /* end of opendir() */
8799 * Set the flag to indicate we want versions or not.
8801 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8803 vmsreaddirversions(DIR *dd, int flag)
8806 dd->flags |= PERL_VMSDIR_M_VERSIONS;
8808 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8813 * Free up an opened directory.
8815 /*{{{ void closedir(DIR *dd)*/
8817 Perl_closedir(DIR *dd)
8821 sts = lib$find_file_end(&dd->context);
8822 Safefree(dd->pattern);
8823 #if defined(USE_ITHREADS)
8824 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8825 Safefree(dd->mutex);
8832 * Collect all the version numbers for the current file.
8835 collectversions(pTHX_ DIR *dd)
8837 struct dsc$descriptor_s pat;
8838 struct dsc$descriptor_s res;
8840 char *p, *text, *buff;
8842 unsigned long context, tmpsts;
8844 /* Convenient shorthand. */
8847 /* Add the version wildcard, ignoring the "*.*" put on before */
8848 i = strlen(dd->pattern);
8849 Newx(text,i + e->d_namlen + 3,char);
8850 strcpy(text, dd->pattern);
8851 sprintf(&text[i - 3], "%s;*", e->d_name);
8853 /* Set up the pattern descriptor. */
8854 pat.dsc$a_pointer = text;
8855 pat.dsc$w_length = i + e->d_namlen - 1;
8856 pat.dsc$b_dtype = DSC$K_DTYPE_T;
8857 pat.dsc$b_class = DSC$K_CLASS_S;
8859 /* Set up result descriptor. */
8860 Newx(buff, VMS_MAXRSS, char);
8861 res.dsc$a_pointer = buff;
8862 res.dsc$w_length = VMS_MAXRSS - 1;
8863 res.dsc$b_dtype = DSC$K_DTYPE_T;
8864 res.dsc$b_class = DSC$K_CLASS_S;
8866 /* Read files, collecting versions. */
8867 for (context = 0, e->vms_verscount = 0;
8868 e->vms_verscount < VERSIZE(e);
8869 e->vms_verscount++) {
8871 unsigned long flags = 0;
8873 #ifdef VMS_LONGNAME_SUPPORT
8874 flags = LIB$M_FIL_LONG_NAMES;
8876 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8877 if (tmpsts == RMS$_NMF || context == 0) break;
8879 buff[VMS_MAXRSS - 1] = '\0';
8880 if ((p = strchr(buff, ';')))
8881 e->vms_versions[e->vms_verscount] = atoi(p + 1);
8883 e->vms_versions[e->vms_verscount] = -1;
8886 _ckvmssts(lib$find_file_end(&context));
8890 } /* end of collectversions() */
8893 * Read the next entry from the directory.
8895 /*{{{ struct dirent *readdir(DIR *dd)*/
8897 Perl_readdir(pTHX_ DIR *dd)
8899 struct dsc$descriptor_s res;
8901 unsigned long int tmpsts;
8903 unsigned long flags = 0;
8904 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8905 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8907 /* Set up result descriptor, and get next file. */
8908 Newx(buff, VMS_MAXRSS, char);
8909 res.dsc$a_pointer = buff;
8910 res.dsc$w_length = VMS_MAXRSS - 1;
8911 res.dsc$b_dtype = DSC$K_DTYPE_T;
8912 res.dsc$b_class = DSC$K_CLASS_S;
8914 #ifdef VMS_LONGNAME_SUPPORT
8915 flags = LIB$M_FIL_LONG_NAMES;
8918 tmpsts = lib$find_file
8919 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8920 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
8921 if (!(tmpsts & 1)) {
8922 set_vaxc_errno(tmpsts);
8925 set_errno(EACCES); break;
8927 set_errno(ENODEV); break;
8929 set_errno(ENOTDIR); break;
8930 case RMS$_FNF: case RMS$_DNF:
8931 set_errno(ENOENT); break;
8939 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8940 if (!decc_efs_case_preserve) {
8941 buff[VMS_MAXRSS - 1] = '\0';
8942 for (p = buff; *p; p++) *p = _tolower(*p);
8945 /* we don't want to force to lowercase, just null terminate */
8946 buff[res.dsc$w_length] = '\0';
8948 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
8951 /* Skip any directory component and just copy the name. */
8952 sts = vms_split_path
8967 /* Drop NULL extensions on UNIX file specification */
8968 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8969 (e_len == 1) && decc_readdir_dropdotnotype)) {
8974 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8975 dd->entry.d_name[n_len + e_len] = '\0';
8976 dd->entry.d_namlen = strlen(dd->entry.d_name);
8978 /* Convert the filename to UNIX format if needed */
8979 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8981 /* Translate the encoded characters. */
8982 /* Fixme: unicode handling could result in embedded 0 characters */
8983 if (strchr(dd->entry.d_name, '^') != NULL) {
8987 p = dd->entry.d_name;
8991 x = copy_expand_vms_filename_escape(q, p, &y);
8995 /* if y > 1, then this is a wide file specification */
8996 /* Wide file specifications need to be passed in Perl */
8997 /* counted strings apparently with a unicode flag */
9000 strcpy(dd->entry.d_name, new_name);
9004 dd->entry.vms_verscount = 0;
9005 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9009 } /* end of readdir() */
9013 * Read the next entry from the directory -- thread-safe version.
9015 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9017 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9021 MUTEX_LOCK( (perl_mutex *) dd->mutex );
9023 entry = readdir(dd);
9025 retval = ( *result == NULL ? errno : 0 );
9027 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9031 } /* end of readdir_r() */
9035 * Return something that can be used in a seekdir later.
9037 /*{{{ long telldir(DIR *dd)*/
9039 Perl_telldir(DIR *dd)
9046 * Return to a spot where we used to be. Brute force.
9048 /*{{{ void seekdir(DIR *dd,long count)*/
9050 Perl_seekdir(pTHX_ DIR *dd, long count)
9054 /* If we haven't done anything yet... */
9058 /* Remember some state, and clear it. */
9059 old_flags = dd->flags;
9060 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9061 _ckvmssts(lib$find_file_end(&dd->context));
9064 /* The increment is in readdir(). */
9065 for (dd->count = 0; dd->count < count; )
9068 dd->flags = old_flags;
9070 } /* end of seekdir() */
9073 /* VMS subprocess management
9075 * my_vfork() - just a vfork(), after setting a flag to record that
9076 * the current script is trying a Unix-style fork/exec.
9078 * vms_do_aexec() and vms_do_exec() are called in response to the
9079 * perl 'exec' function. If this follows a vfork call, then they
9080 * call out the regular perl routines in doio.c which do an
9081 * execvp (for those who really want to try this under VMS).
9082 * Otherwise, they do exactly what the perl docs say exec should
9083 * do - terminate the current script and invoke a new command
9084 * (See below for notes on command syntax.)
9086 * do_aspawn() and do_spawn() implement the VMS side of the perl
9087 * 'system' function.
9089 * Note on command arguments to perl 'exec' and 'system': When handled
9090 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9091 * are concatenated to form a DCL command string. If the first arg
9092 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9093 * the command string is handed off to DCL directly. Otherwise,
9094 * the first token of the command is taken as the filespec of an image
9095 * to run. The filespec is expanded using a default type of '.EXE' and
9096 * the process defaults for device, directory, etc., and if found, the resultant
9097 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9098 * the command string as parameters. This is perhaps a bit complicated,
9099 * but I hope it will form a happy medium between what VMS folks expect
9100 * from lib$spawn and what Unix folks expect from exec.
9103 static int vfork_called;
9105 /*{{{int my_vfork()*/
9116 vms_execfree(struct dsc$descriptor_s *vmscmd)
9119 if (vmscmd->dsc$a_pointer) {
9120 PerlMem_free(vmscmd->dsc$a_pointer);
9122 PerlMem_free(vmscmd);
9127 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9129 char *junk, *tmps = Nullch;
9130 register size_t cmdlen = 0;
9137 tmps = SvPV(really,rlen);
9144 for (idx++; idx <= sp; idx++) {
9146 junk = SvPVx(*idx,rlen);
9147 cmdlen += rlen ? rlen + 1 : 0;
9150 Newx(PL_Cmd, cmdlen+1, char);
9152 if (tmps && *tmps) {
9153 strcpy(PL_Cmd,tmps);
9156 else *PL_Cmd = '\0';
9157 while (++mark <= sp) {
9159 char *s = SvPVx(*mark,n_a);
9161 if (*PL_Cmd) strcat(PL_Cmd," ");
9167 } /* end of setup_argstr() */
9170 static unsigned long int
9171 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9172 struct dsc$descriptor_s **pvmscmd)
9174 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9175 char image_name[NAM$C_MAXRSS+1];
9176 char image_argv[NAM$C_MAXRSS+1];
9177 $DESCRIPTOR(defdsc,".EXE");
9178 $DESCRIPTOR(defdsc2,".");
9179 $DESCRIPTOR(resdsc,resspec);
9180 struct dsc$descriptor_s *vmscmd;
9181 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9182 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9183 register char *s, *rest, *cp, *wordbreak;
9188 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9189 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9191 /* Make a copy for modification */
9192 cmdlen = strlen(incmd);
9193 cmd = PerlMem_malloc(cmdlen+1);
9194 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9195 strncpy(cmd, incmd, cmdlen);
9200 vmscmd->dsc$a_pointer = NULL;
9201 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
9202 vmscmd->dsc$b_class = DSC$K_CLASS_S;
9203 vmscmd->dsc$w_length = 0;
9204 if (pvmscmd) *pvmscmd = vmscmd;
9206 if (suggest_quote) *suggest_quote = 0;
9208 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9210 return CLI$_BUFOVF; /* continuation lines currently unsupported */
9215 while (*s && isspace(*s)) s++;
9217 if (*s == '@' || *s == '$') {
9218 vmsspec[0] = *s; rest = s + 1;
9219 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9221 else { cp = vmsspec; rest = s; }
9222 if (*rest == '.' || *rest == '/') {
9225 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9226 rest++, cp2++) *cp2 = *rest;
9228 if (do_tovmsspec(resspec,cp,0,NULL)) {
9231 for (cp2 = vmsspec + strlen(vmsspec);
9232 *rest && cp2 - vmsspec < sizeof vmsspec;
9233 rest++, cp2++) *cp2 = *rest;
9238 /* Intuit whether verb (first word of cmd) is a DCL command:
9239 * - if first nonspace char is '@', it's a DCL indirection
9241 * - if verb contains a filespec separator, it's not a DCL command
9242 * - if it doesn't, caller tells us whether to default to a DCL
9243 * command, or to a local image unless told it's DCL (by leading '$')
9247 if (suggest_quote) *suggest_quote = 1;
9249 register char *filespec = strpbrk(s,":<[.;");
9250 rest = wordbreak = strpbrk(s," \"\t/");
9251 if (!wordbreak) wordbreak = s + strlen(s);
9252 if (*s == '$') check_img = 0;
9253 if (filespec && (filespec < wordbreak)) isdcl = 0;
9254 else isdcl = !check_img;
9259 imgdsc.dsc$a_pointer = s;
9260 imgdsc.dsc$w_length = wordbreak - s;
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);
9265 if (!(retsts & 1) && *s == '$') {
9266 _ckvmssts(lib$find_file_end(&cxt));
9267 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9268 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9270 _ckvmssts(lib$find_file_end(&cxt));
9271 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9275 _ckvmssts(lib$find_file_end(&cxt));
9280 while (*s && !isspace(*s)) s++;
9283 /* check that it's really not DCL with no file extension */
9284 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9286 char b[256] = {0,0,0,0};
9287 read(fileno(fp), b, 256);
9288 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9292 /* Check for script */
9294 if ((b[0] == '#') && (b[1] == '!'))
9296 #ifdef ALTERNATE_SHEBANG
9298 shebang_len = strlen(ALTERNATE_SHEBANG);
9299 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9301 perlstr = strstr("perl",b);
9302 if (perlstr == NULL)
9310 if (shebang_len > 0) {
9313 char tmpspec[NAM$C_MAXRSS + 1];
9316 /* Image is following after white space */
9317 /*--------------------------------------*/
9318 while (isprint(b[i]) && isspace(b[i]))
9322 while (isprint(b[i]) && !isspace(b[i])) {
9323 tmpspec[j++] = b[i++];
9324 if (j >= NAM$C_MAXRSS)
9329 /* There may be some default parameters to the image */
9330 /*---------------------------------------------------*/
9332 while (isprint(b[i])) {
9333 image_argv[j++] = b[i++];
9334 if (j >= NAM$C_MAXRSS)
9337 while ((j > 0) && !isprint(image_argv[j-1]))
9341 /* It will need to be converted to VMS format and validated */
9342 if (tmpspec[0] != '\0') {
9345 /* Try to find the exact program requested to be run */
9346 /*---------------------------------------------------*/
9347 iname = do_rmsexpand
9348 (tmpspec, image_name, 0, ".exe",
9349 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9350 if (iname != NULL) {
9351 if (cando_by_name_int
9352 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9353 /* MCR prefix needed */
9357 /* Try again with a null type */
9358 /*----------------------------*/
9359 iname = do_rmsexpand
9360 (tmpspec, image_name, 0, ".",
9361 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9362 if (iname != NULL) {
9363 if (cando_by_name_int
9364 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9365 /* MCR prefix needed */
9371 /* Did we find the image to run the script? */
9372 /*------------------------------------------*/
9376 /* Assume DCL or foreign command exists */
9377 /*--------------------------------------*/
9378 tchr = strrchr(tmpspec, '/');
9385 strcpy(image_name, tchr);
9393 if (check_img && isdcl) return RMS$_FNF;
9395 if (cando_by_name(S_IXUSR,0,resspec)) {
9396 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9397 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9399 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9400 if (image_name[0] != 0) {
9401 strcat(vmscmd->dsc$a_pointer, image_name);
9402 strcat(vmscmd->dsc$a_pointer, " ");
9404 } else if (image_name[0] != 0) {
9405 strcpy(vmscmd->dsc$a_pointer, image_name);
9406 strcat(vmscmd->dsc$a_pointer, " ");
9408 strcpy(vmscmd->dsc$a_pointer,"@");
9410 if (suggest_quote) *suggest_quote = 1;
9412 /* If there is an image name, use original command */
9413 if (image_name[0] == 0)
9414 strcat(vmscmd->dsc$a_pointer,resspec);
9417 while (*rest && isspace(*rest)) rest++;
9420 if (image_argv[0] != 0) {
9421 strcat(vmscmd->dsc$a_pointer,image_argv);
9422 strcat(vmscmd->dsc$a_pointer, " ");
9428 rest_len = strlen(rest);
9429 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9430 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9431 strcat(vmscmd->dsc$a_pointer,rest);
9433 retsts = CLI$_BUFOVF;
9435 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9437 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9443 /* It's either a DCL command or we couldn't find a suitable image */
9444 vmscmd->dsc$w_length = strlen(cmd);
9446 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9447 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9448 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9452 /* check if it's a symbol (for quoting purposes) */
9453 if (suggest_quote && !*suggest_quote) {
9455 char equiv[LNM$C_NAMLENGTH];
9456 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9457 eqvdsc.dsc$a_pointer = equiv;
9459 iss = lib$get_symbol(vmscmd,&eqvdsc);
9460 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9462 if (!(retsts & 1)) {
9463 /* just hand off status values likely to be due to user error */
9464 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9465 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9466 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9467 else { _ckvmssts(retsts); }
9470 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9472 } /* end of setup_cmddsc() */
9475 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9477 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9483 if (vfork_called) { /* this follows a vfork - act Unixish */
9485 if (vfork_called < 0) {
9486 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9489 else return do_aexec(really,mark,sp);
9491 /* no vfork - act VMSish */
9492 cmd = setup_argstr(aTHX_ really,mark,sp);
9493 exec_sts = vms_do_exec(cmd);
9494 Safefree(cmd); /* Clean up from setup_argstr() */
9499 } /* end of vms_do_aexec() */
9502 /* {{{bool vms_do_exec(char *cmd) */
9504 Perl_vms_do_exec(pTHX_ const char *cmd)
9506 struct dsc$descriptor_s *vmscmd;
9508 if (vfork_called) { /* this follows a vfork - act Unixish */
9510 if (vfork_called < 0) {
9511 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9514 else return do_exec(cmd);
9517 { /* no vfork - act VMSish */
9518 unsigned long int retsts;
9521 TAINT_PROPER("exec");
9522 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9523 retsts = lib$do_command(vmscmd);
9526 case RMS$_FNF: case RMS$_DNF:
9527 set_errno(ENOENT); break;
9529 set_errno(ENOTDIR); break;
9531 set_errno(ENODEV); break;
9533 set_errno(EACCES); break;
9535 set_errno(EINVAL); break;
9536 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9537 set_errno(E2BIG); break;
9538 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9539 _ckvmssts(retsts); /* fall through */
9540 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9543 set_vaxc_errno(retsts);
9544 if (ckWARN(WARN_EXEC)) {
9545 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9546 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9548 vms_execfree(vmscmd);
9553 } /* end of vms_do_exec() */
9556 unsigned long int Perl_do_spawn(pTHX_ const char *);
9558 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9560 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9562 unsigned long int sts;
9566 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9567 sts = do_spawn(cmd);
9568 /* pp_sys will clean up cmd */
9572 } /* end of do_aspawn() */
9575 /* {{{unsigned long int do_spawn(char *cmd) */
9577 Perl_do_spawn(pTHX_ const char *cmd)
9579 unsigned long int sts, substs;
9581 /* The caller of this routine expects to Safefree(PL_Cmd) */
9582 Newx(PL_Cmd,10,char);
9585 TAINT_PROPER("spawn");
9586 if (!cmd || !*cmd) {
9587 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9590 case RMS$_FNF: case RMS$_DNF:
9591 set_errno(ENOENT); break;
9593 set_errno(ENOTDIR); break;
9595 set_errno(ENODEV); break;
9597 set_errno(EACCES); break;
9599 set_errno(EINVAL); break;
9600 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9601 set_errno(E2BIG); break;
9602 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9603 _ckvmssts(sts); /* fall through */
9604 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9607 set_vaxc_errno(sts);
9608 if (ckWARN(WARN_EXEC)) {
9609 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9617 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9622 } /* end of do_spawn() */
9626 static unsigned int *sockflags, sockflagsize;
9629 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9630 * routines found in some versions of the CRTL can't deal with sockets.
9631 * We don't shim the other file open routines since a socket isn't
9632 * likely to be opened by a name.
9634 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9635 FILE *my_fdopen(int fd, const char *mode)
9637 FILE *fp = fdopen(fd, mode);
9640 unsigned int fdoff = fd / sizeof(unsigned int);
9641 Stat_t sbuf; /* native stat; we don't need flex_stat */
9642 if (!sockflagsize || fdoff > sockflagsize) {
9643 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
9644 else Newx (sockflags,fdoff+2,unsigned int);
9645 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9646 sockflagsize = fdoff + 2;
9648 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9649 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9658 * Clear the corresponding bit when the (possibly) socket stream is closed.
9659 * There still a small hole: we miss an implicit close which might occur
9660 * via freopen(). >> Todo
9662 /*{{{ int my_fclose(FILE *fp)*/
9663 int my_fclose(FILE *fp) {
9665 unsigned int fd = fileno(fp);
9666 unsigned int fdoff = fd / sizeof(unsigned int);
9668 if (sockflagsize && fdoff <= sockflagsize)
9669 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9677 * A simple fwrite replacement which outputs itmsz*nitm chars without
9678 * introducing record boundaries every itmsz chars.
9679 * We are using fputs, which depends on a terminating null. We may
9680 * well be writing binary data, so we need to accommodate not only
9681 * data with nulls sprinkled in the middle but also data with no null
9684 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9686 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9688 register char *cp, *end, *cpd, *data;
9689 register unsigned int fd = fileno(dest);
9690 register unsigned int fdoff = fd / sizeof(unsigned int);
9692 int bufsize = itmsz * nitm + 1;
9694 if (fdoff < sockflagsize &&
9695 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9696 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9700 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9701 memcpy( data, src, itmsz*nitm );
9702 data[itmsz*nitm] = '\0';
9704 end = data + itmsz * nitm;
9705 retval = (int) nitm; /* on success return # items written */
9708 while (cpd <= end) {
9709 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9710 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9712 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9716 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9719 } /* end of my_fwrite() */
9722 /*{{{ int my_flush(FILE *fp)*/
9724 Perl_my_flush(pTHX_ FILE *fp)
9727 if ((res = fflush(fp)) == 0 && fp) {
9728 #ifdef VMS_DO_SOCKETS
9730 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9732 res = fsync(fileno(fp));
9735 * If the flush succeeded but set end-of-file, we need to clear
9736 * the error because our caller may check ferror(). BTW, this
9737 * probably means we just flushed an empty file.
9739 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9746 * Here are replacements for the following Unix routines in the VMS environment:
9747 * getpwuid Get information for a particular UIC or UID
9748 * getpwnam Get information for a named user
9749 * getpwent Get information for each user in the rights database
9750 * setpwent Reset search to the start of the rights database
9751 * endpwent Finish searching for users in the rights database
9753 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9754 * (defined in pwd.h), which contains the following fields:-
9756 * char *pw_name; Username (in lower case)
9757 * char *pw_passwd; Hashed password
9758 * unsigned int pw_uid; UIC
9759 * unsigned int pw_gid; UIC group number
9760 * char *pw_unixdir; Default device/directory (VMS-style)
9761 * char *pw_gecos; Owner name
9762 * char *pw_dir; Default device/directory (Unix-style)
9763 * char *pw_shell; Default CLI name (eg. DCL)
9765 * If the specified user does not exist, getpwuid and getpwnam return NULL.
9767 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9768 * not the UIC member number (eg. what's returned by getuid()),
9769 * getpwuid() can accept either as input (if uid is specified, the caller's
9770 * UIC group is used), though it won't recognise gid=0.
9772 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9773 * information about other users in your group or in other groups, respectively.
9774 * If the required privilege is not available, then these routines fill only
9775 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9778 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9781 /* sizes of various UAF record fields */
9782 #define UAI$S_USERNAME 12
9783 #define UAI$S_IDENT 31
9784 #define UAI$S_OWNER 31
9785 #define UAI$S_DEFDEV 31
9786 #define UAI$S_DEFDIR 63
9787 #define UAI$S_DEFCLI 31
9790 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
9791 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9792 (uic).uic$v_group != UIC$K_WILD_GROUP)
9794 static char __empty[]= "";
9795 static struct passwd __passwd_empty=
9796 {(char *) __empty, (char *) __empty, 0, 0,
9797 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9798 static int contxt= 0;
9799 static struct passwd __pwdcache;
9800 static char __pw_namecache[UAI$S_IDENT+1];
9803 * This routine does most of the work extracting the user information.
9805 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9808 unsigned char length;
9809 char pw_gecos[UAI$S_OWNER+1];
9811 static union uicdef uic;
9813 unsigned char length;
9814 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9817 unsigned char length;
9818 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9821 unsigned char length;
9822 char pw_shell[UAI$S_DEFCLI+1];
9824 static char pw_passwd[UAI$S_PWD+1];
9826 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9827 struct dsc$descriptor_s name_desc;
9828 unsigned long int sts;
9830 static struct itmlst_3 itmlst[]= {
9831 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
9832 {sizeof(uic), UAI$_UIC, &uic, &luic},
9833 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
9834 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
9835 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
9836 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
9837 {0, 0, NULL, NULL}};
9839 name_desc.dsc$w_length= strlen(name);
9840 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9841 name_desc.dsc$b_class= DSC$K_CLASS_S;
9842 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9844 /* Note that sys$getuai returns many fields as counted strings. */
9845 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9846 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9847 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9849 else { _ckvmssts(sts); }
9850 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
9852 if ((int) owner.length < lowner) lowner= (int) owner.length;
9853 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9854 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9855 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9856 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9857 owner.pw_gecos[lowner]= '\0';
9858 defdev.pw_dir[ldefdev+ldefdir]= '\0';
9859 defcli.pw_shell[ldefcli]= '\0';
9860 if (valid_uic(uic)) {
9861 pwd->pw_uid= uic.uic$l_uic;
9862 pwd->pw_gid= uic.uic$v_group;
9865 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9866 pwd->pw_passwd= pw_passwd;
9867 pwd->pw_gecos= owner.pw_gecos;
9868 pwd->pw_dir= defdev.pw_dir;
9869 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9870 pwd->pw_shell= defcli.pw_shell;
9871 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9873 ldir= strlen(pwd->pw_unixdir) - 1;
9874 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9877 strcpy(pwd->pw_unixdir, pwd->pw_dir);
9878 if (!decc_efs_case_preserve)
9879 __mystrtolower(pwd->pw_unixdir);
9884 * Get information for a named user.
9886 /*{{{struct passwd *getpwnam(char *name)*/
9887 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9889 struct dsc$descriptor_s name_desc;
9891 unsigned long int status, sts;
9893 __pwdcache = __passwd_empty;
9894 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9895 /* We still may be able to determine pw_uid and pw_gid */
9896 name_desc.dsc$w_length= strlen(name);
9897 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9898 name_desc.dsc$b_class= DSC$K_CLASS_S;
9899 name_desc.dsc$a_pointer= (char *) name;
9900 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9901 __pwdcache.pw_uid= uic.uic$l_uic;
9902 __pwdcache.pw_gid= uic.uic$v_group;
9905 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9906 set_vaxc_errno(sts);
9907 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9910 else { _ckvmssts(sts); }
9913 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9914 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9915 __pwdcache.pw_name= __pw_namecache;
9917 } /* end of my_getpwnam() */
9921 * Get information for a particular UIC or UID.
9922 * Called by my_getpwent with uid=-1 to list all users.
9924 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9925 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9927 const $DESCRIPTOR(name_desc,__pw_namecache);
9928 unsigned short lname;
9930 unsigned long int status;
9932 if (uid == (unsigned int) -1) {
9934 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9935 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9936 set_vaxc_errno(status);
9937 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9941 else { _ckvmssts(status); }
9942 } while (!valid_uic (uic));
9946 if (!uic.uic$v_group)
9947 uic.uic$v_group= PerlProc_getgid();
9949 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9950 else status = SS$_IVIDENT;
9951 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9952 status == RMS$_PRV) {
9953 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9956 else { _ckvmssts(status); }
9958 __pw_namecache[lname]= '\0';
9959 __mystrtolower(__pw_namecache);
9961 __pwdcache = __passwd_empty;
9962 __pwdcache.pw_name = __pw_namecache;
9964 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9965 The identifier's value is usually the UIC, but it doesn't have to be,
9966 so if we can, we let fillpasswd update this. */
9967 __pwdcache.pw_uid = uic.uic$l_uic;
9968 __pwdcache.pw_gid = uic.uic$v_group;
9970 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9973 } /* end of my_getpwuid() */
9977 * Get information for next user.
9979 /*{{{struct passwd *my_getpwent()*/
9980 struct passwd *Perl_my_getpwent(pTHX)
9982 return (my_getpwuid((unsigned int) -1));
9987 * Finish searching rights database for users.
9989 /*{{{void my_endpwent()*/
9990 void Perl_my_endpwent(pTHX)
9993 _ckvmssts(sys$finish_rdb(&contxt));
9999 #ifdef HOMEGROWN_POSIX_SIGNALS
10000 /* Signal handling routines, pulled into the core from POSIX.xs.
10002 * We need these for threads, so they've been rolled into the core,
10003 * rather than left in POSIX.xs.
10005 * (DRS, Oct 23, 1997)
10008 /* sigset_t is atomic under VMS, so these routines are easy */
10009 /*{{{int my_sigemptyset(sigset_t *) */
10010 int my_sigemptyset(sigset_t *set) {
10011 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10012 *set = 0; return 0;
10017 /*{{{int my_sigfillset(sigset_t *)*/
10018 int my_sigfillset(sigset_t *set) {
10020 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10021 for (i = 0; i < NSIG; i++) *set |= (1 << i);
10027 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10028 int my_sigaddset(sigset_t *set, int sig) {
10029 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10030 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10031 *set |= (1 << (sig - 1));
10037 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10038 int my_sigdelset(sigset_t *set, int sig) {
10039 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10040 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10041 *set &= ~(1 << (sig - 1));
10047 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10048 int my_sigismember(sigset_t *set, int sig) {
10049 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10050 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10051 return *set & (1 << (sig - 1));
10056 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10057 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10060 /* If set and oset are both null, then things are badly wrong. Bail out. */
10061 if ((oset == NULL) && (set == NULL)) {
10062 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10066 /* If set's null, then we're just handling a fetch. */
10068 tempmask = sigblock(0);
10073 tempmask = sigsetmask(*set);
10076 tempmask = sigblock(*set);
10079 tempmask = sigblock(0);
10080 sigsetmask(*oset & ~tempmask);
10083 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10088 /* Did they pass us an oset? If so, stick our holding mask into it */
10095 #endif /* HOMEGROWN_POSIX_SIGNALS */
10098 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10099 * my_utime(), and flex_stat(), all of which operate on UTC unless
10100 * VMSISH_TIMES is true.
10102 /* method used to handle UTC conversions:
10103 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
10105 static int gmtime_emulation_type;
10106 /* number of secs to add to UTC POSIX-style time to get local time */
10107 static long int utc_offset_secs;
10109 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10110 * in vmsish.h. #undef them here so we can call the CRTL routines
10119 * DEC C previous to 6.0 corrupts the behavior of the /prefix
10120 * qualifier with the extern prefix pragma. This provisional
10121 * hack circumvents this prefix pragma problem in previous
10124 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10125 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10126 # pragma __extern_prefix save
10127 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
10128 # define gmtime decc$__utctz_gmtime
10129 # define localtime decc$__utctz_localtime
10130 # define time decc$__utc_time
10131 # pragma __extern_prefix restore
10133 struct tm *gmtime(), *localtime();
10139 static time_t toutc_dst(time_t loc) {
10142 if ((rsltmp = localtime(&loc)) == NULL) return -1;
10143 loc -= utc_offset_secs;
10144 if (rsltmp->tm_isdst) loc -= 3600;
10147 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10148 ((gmtime_emulation_type || my_time(NULL)), \
10149 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10150 ((secs) - utc_offset_secs))))
10152 static time_t toloc_dst(time_t utc) {
10155 utc += utc_offset_secs;
10156 if ((rsltmp = localtime(&utc)) == NULL) return -1;
10157 if (rsltmp->tm_isdst) utc += 3600;
10160 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10161 ((gmtime_emulation_type || my_time(NULL)), \
10162 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10163 ((secs) + utc_offset_secs))))
10165 #ifndef RTL_USES_UTC
10168 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
10169 DST starts on 1st sun of april at 02:00 std time
10170 ends on last sun of october at 02:00 dst time
10171 see the UCX management command reference, SET CONFIG TIMEZONE
10172 for formatting info.
10174 No, it's not as general as it should be, but then again, NOTHING
10175 will handle UK times in a sensible way.
10180 parse the DST start/end info:
10181 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10185 tz_parse_startend(char *s, struct tm *w, int *past)
10187 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10188 int ly, dozjd, d, m, n, hour, min, sec, j, k;
10193 if (!past) return 0;
10196 if (w->tm_year % 4 == 0) ly = 1;
10197 if (w->tm_year % 100 == 0) ly = 0;
10198 if (w->tm_year+1900 % 400 == 0) ly = 1;
10201 dozjd = isdigit(*s);
10202 if (*s == 'J' || *s == 'j' || dozjd) {
10203 if (!dozjd && !isdigit(*++s)) return 0;
10206 d = d*10 + *s++ - '0';
10208 d = d*10 + *s++ - '0';
10211 if (d == 0) return 0;
10212 if (d > 366) return 0;
10214 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
10217 } else if (*s == 'M' || *s == 'm') {
10218 if (!isdigit(*++s)) return 0;
10220 if (isdigit(*s)) m = 10*m + *s++ - '0';
10221 if (*s != '.') return 0;
10222 if (!isdigit(*++s)) return 0;
10224 if (n < 1 || n > 5) return 0;
10225 if (*s != '.') return 0;
10226 if (!isdigit(*++s)) return 0;
10228 if (d > 6) return 0;
10232 if (!isdigit(*++s)) return 0;
10234 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10236 if (!isdigit(*++s)) return 0;
10238 if (isdigit(*s)) min = 10*min + *s++ - '0';
10240 if (!isdigit(*++s)) return 0;
10242 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10252 if (w->tm_yday < d) goto before;
10253 if (w->tm_yday > d) goto after;
10255 if (w->tm_mon+1 < m) goto before;
10256 if (w->tm_mon+1 > m) goto after;
10258 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
10259 k = d - j; /* mday of first d */
10260 if (k <= 0) k += 7;
10261 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
10262 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10263 if (w->tm_mday < k) goto before;
10264 if (w->tm_mday > k) goto after;
10267 if (w->tm_hour < hour) goto before;
10268 if (w->tm_hour > hour) goto after;
10269 if (w->tm_min < min) goto before;
10270 if (w->tm_min > min) goto after;
10271 if (w->tm_sec < sec) goto before;
10285 /* parse the offset: (+|-)hh[:mm[:ss]] */
10288 tz_parse_offset(char *s, int *offset)
10290 int hour = 0, min = 0, sec = 0;
10293 if (!offset) return 0;
10295 if (*s == '-') {neg++; s++;}
10296 if (*s == '+') s++;
10297 if (!isdigit(*s)) return 0;
10299 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10300 if (hour > 24) return 0;
10302 if (!isdigit(*++s)) return 0;
10304 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10305 if (min > 59) return 0;
10307 if (!isdigit(*++s)) return 0;
10309 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10310 if (sec > 59) return 0;
10314 *offset = (hour*60+min)*60 + sec;
10315 if (neg) *offset = -*offset;
10320 input time is w, whatever type of time the CRTL localtime() uses.
10321 sets dst, the zone, and the gmtoff (seconds)
10323 caches the value of TZ and UCX$TZ env variables; note that
10324 my_setenv looks for these and sets a flag if they're changed
10327 We have to watch out for the "australian" case (dst starts in
10328 october, ends in april)...flagged by "reverse" and checked by
10329 scanning through the months of the previous year.
10334 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10339 char *dstzone, *tz, *s_start, *s_end;
10340 int std_off, dst_off, isdst;
10341 int y, dststart, dstend;
10342 static char envtz[1025]; /* longer than any logical, symbol, ... */
10343 static char ucxtz[1025];
10344 static char reversed = 0;
10350 reversed = -1; /* flag need to check */
10351 envtz[0] = ucxtz[0] = '\0';
10352 tz = my_getenv("TZ",0);
10353 if (tz) strcpy(envtz, tz);
10354 tz = my_getenv("UCX$TZ",0);
10355 if (tz) strcpy(ucxtz, tz);
10356 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
10359 if (!*tz) tz = ucxtz;
10362 while (isalpha(*s)) s++;
10363 s = tz_parse_offset(s, &std_off);
10365 if (!*s) { /* no DST, hurray we're done! */
10371 while (isalpha(*s)) s++;
10372 s2 = tz_parse_offset(s, &dst_off);
10376 dst_off = std_off - 3600;
10379 if (!*s) { /* default dst start/end?? */
10380 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
10381 s = strchr(ucxtz,',');
10383 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
10385 if (*s != ',') return 0;
10388 when = _toutc(when); /* convert to utc */
10389 when = when - std_off; /* convert to pseudolocal time*/
10391 w2 = localtime(&when);
10394 s = tz_parse_startend(s_start,w2,&dststart);
10396 if (*s != ',') return 0;
10399 when = _toutc(when); /* convert to utc */
10400 when = when - dst_off; /* convert to pseudolocal time*/
10401 w2 = localtime(&when);
10402 if (w2->tm_year != y) { /* spans a year, just check one time */
10403 when += dst_off - std_off;
10404 w2 = localtime(&when);
10407 s = tz_parse_startend(s_end,w2,&dstend);
10410 if (reversed == -1) { /* need to check if start later than end */
10414 if (when < 2*365*86400) {
10415 when += 2*365*86400;
10419 w2 =localtime(&when);
10420 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
10422 for (j = 0; j < 12; j++) {
10423 w2 =localtime(&when);
10424 tz_parse_startend(s_start,w2,&ds);
10425 tz_parse_startend(s_end,w2,&de);
10426 if (ds != de) break;
10430 if (de && !ds) reversed = 1;
10433 isdst = dststart && !dstend;
10434 if (reversed) isdst = dststart || !dstend;
10437 if (dst) *dst = isdst;
10438 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10439 if (isdst) tz = dstzone;
10441 while(isalpha(*tz)) *zone++ = *tz++;
10447 #endif /* !RTL_USES_UTC */
10449 /* my_time(), my_localtime(), my_gmtime()
10450 * By default traffic in UTC time values, using CRTL gmtime() or
10451 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10452 * Note: We need to use these functions even when the CRTL has working
10453 * UTC support, since they also handle C<use vmsish qw(times);>
10455 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
10456 * Modified by Charles Bailey <bailey@newman.upenn.edu>
10459 /*{{{time_t my_time(time_t *timep)*/
10460 time_t Perl_my_time(pTHX_ time_t *timep)
10465 if (gmtime_emulation_type == 0) {
10467 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
10468 /* results of calls to gmtime() and localtime() */
10469 /* for same &base */
10471 gmtime_emulation_type++;
10472 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10473 char off[LNM$C_NAMLENGTH+1];;
10475 gmtime_emulation_type++;
10476 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10477 gmtime_emulation_type++;
10478 utc_offset_secs = 0;
10479 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10481 else { utc_offset_secs = atol(off); }
10483 else { /* We've got a working gmtime() */
10484 struct tm gmt, local;
10487 tm_p = localtime(&base);
10489 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
10490 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10491 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
10492 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
10497 # ifdef VMSISH_TIME
10498 # ifdef RTL_USES_UTC
10499 if (VMSISH_TIME) when = _toloc(when);
10501 if (!VMSISH_TIME) when = _toutc(when);
10504 if (timep != NULL) *timep = when;
10507 } /* end of my_time() */
10511 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10513 Perl_my_gmtime(pTHX_ const time_t *timep)
10519 if (timep == NULL) {
10520 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10523 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10526 # ifdef VMSISH_TIME
10527 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10529 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
10530 return gmtime(&when);
10532 /* CRTL localtime() wants local time as input, so does no tz correction */
10533 rsltmp = localtime(&when);
10534 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
10537 } /* end of my_gmtime() */
10541 /*{{{struct tm *my_localtime(const time_t *timep)*/
10543 Perl_my_localtime(pTHX_ const time_t *timep)
10545 time_t when, whenutc;
10549 if (timep == NULL) {
10550 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10553 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10554 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10557 # ifdef RTL_USES_UTC
10558 # ifdef VMSISH_TIME
10559 if (VMSISH_TIME) when = _toutc(when);
10561 /* CRTL localtime() wants UTC as input, does tz correction itself */
10562 return localtime(&when);
10564 # else /* !RTL_USES_UTC */
10566 # ifdef VMSISH_TIME
10567 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
10568 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
10571 #ifndef RTL_USES_UTC
10572 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
10573 when = whenutc - offset; /* pseudolocal time*/
10576 /* CRTL localtime() wants local time as input, so does no tz correction */
10577 rsltmp = localtime(&when);
10578 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10582 } /* end of my_localtime() */
10585 /* Reset definitions for later calls */
10586 #define gmtime(t) my_gmtime(t)
10587 #define localtime(t) my_localtime(t)
10588 #define time(t) my_time(t)
10591 /* my_utime - update modification/access time of a file
10593 * VMS 7.3 and later implementation
10594 * Only the UTC translation is home-grown. The rest is handled by the
10595 * CRTL utime(), which will take into account the relevant feature
10596 * logicals and ODS-5 volume characteristics for true access times.
10598 * pre VMS 7.3 implementation:
10599 * The calling sequence is identical to POSIX utime(), but under
10600 * VMS with ODS-2, only the modification time is changed; ODS-2 does
10601 * not maintain access times. Restrictions differ from the POSIX
10602 * definition in that the time can be changed as long as the
10603 * caller has permission to execute the necessary IO$_MODIFY $QIO;
10604 * no separate checks are made to insure that the caller is the
10605 * owner of the file or has special privs enabled.
10606 * Code here is based on Joe Meadows' FILE utility.
10610 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10611 * to VMS epoch (01-JAN-1858 00:00:00.00)
10612 * in 100 ns intervals.
10614 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10616 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10617 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10619 #if __CRTL_VER >= 70300000
10620 struct utimbuf utc_utimes, *utc_utimesp;
10622 if (utimes != NULL) {
10623 utc_utimes.actime = utimes->actime;
10624 utc_utimes.modtime = utimes->modtime;
10625 # ifdef VMSISH_TIME
10626 /* If input was local; convert to UTC for sys svc */
10628 utc_utimes.actime = _toutc(utimes->actime);
10629 utc_utimes.modtime = _toutc(utimes->modtime);
10632 utc_utimesp = &utc_utimes;
10635 utc_utimesp = NULL;
10638 return utime(file, utc_utimesp);
10640 #else /* __CRTL_VER < 70300000 */
10644 long int bintime[2], len = 2, lowbit, unixtime,
10645 secscale = 10000000; /* seconds --> 100 ns intervals */
10646 unsigned long int chan, iosb[2], retsts;
10647 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10648 struct FAB myfab = cc$rms_fab;
10649 struct NAM mynam = cc$rms_nam;
10650 #if defined (__DECC) && defined (__VAX)
10651 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10652 * at least through VMS V6.1, which causes a type-conversion warning.
10654 # pragma message save
10655 # pragma message disable cvtdiftypes
10657 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10658 struct fibdef myfib;
10659 #if defined (__DECC) && defined (__VAX)
10660 /* This should be right after the declaration of myatr, but due
10661 * to a bug in VAX DEC C, this takes effect a statement early.
10663 # pragma message restore
10665 /* cast ok for read only parameter */
10666 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10667 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10668 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10670 if (file == NULL || *file == '\0') {
10671 SETERRNO(ENOENT, LIB$_INVARG);
10675 /* Convert to VMS format ensuring that it will fit in 255 characters */
10676 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10677 SETERRNO(ENOENT, LIB$_INVARG);
10680 if (utimes != NULL) {
10681 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
10682 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10683 * Since time_t is unsigned long int, and lib$emul takes a signed long int
10684 * as input, we force the sign bit to be clear by shifting unixtime right
10685 * one bit, then multiplying by an extra factor of 2 in lib$emul().
10687 lowbit = (utimes->modtime & 1) ? secscale : 0;
10688 unixtime = (long int) utimes->modtime;
10689 # ifdef VMSISH_TIME
10690 /* If input was UTC; convert to local for sys svc */
10691 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10693 unixtime >>= 1; secscale <<= 1;
10694 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10695 if (!(retsts & 1)) {
10696 SETERRNO(EVMSERR, retsts);
10699 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10700 if (!(retsts & 1)) {
10701 SETERRNO(EVMSERR, retsts);
10706 /* Just get the current time in VMS format directly */
10707 retsts = sys$gettim(bintime);
10708 if (!(retsts & 1)) {
10709 SETERRNO(EVMSERR, retsts);
10714 myfab.fab$l_fna = vmsspec;
10715 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10716 myfab.fab$l_nam = &mynam;
10717 mynam.nam$l_esa = esa;
10718 mynam.nam$b_ess = (unsigned char) sizeof esa;
10719 mynam.nam$l_rsa = rsa;
10720 mynam.nam$b_rss = (unsigned char) sizeof rsa;
10721 if (decc_efs_case_preserve)
10722 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10724 /* Look for the file to be affected, letting RMS parse the file
10725 * specification for us as well. I have set errno using only
10726 * values documented in the utime() man page for VMS POSIX.
10728 retsts = sys$parse(&myfab,0,0);
10729 if (!(retsts & 1)) {
10730 set_vaxc_errno(retsts);
10731 if (retsts == RMS$_PRV) set_errno(EACCES);
10732 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10733 else set_errno(EVMSERR);
10736 retsts = sys$search(&myfab,0,0);
10737 if (!(retsts & 1)) {
10738 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10739 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10740 set_vaxc_errno(retsts);
10741 if (retsts == RMS$_PRV) set_errno(EACCES);
10742 else if (retsts == RMS$_FNF) set_errno(ENOENT);
10743 else set_errno(EVMSERR);
10747 devdsc.dsc$w_length = mynam.nam$b_dev;
10748 /* cast ok for read only parameter */
10749 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10751 retsts = sys$assign(&devdsc,&chan,0,0);
10752 if (!(retsts & 1)) {
10753 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10754 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10755 set_vaxc_errno(retsts);
10756 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
10757 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
10758 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
10759 else set_errno(EVMSERR);
10763 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10764 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10766 memset((void *) &myfib, 0, sizeof myfib);
10767 #if defined(__DECC) || defined(__DECCXX)
10768 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10769 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10770 /* This prevents the revision time of the file being reset to the current
10771 * time as a result of our IO$_MODIFY $QIO. */
10772 myfib.fib$l_acctl = FIB$M_NORECORD;
10774 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10775 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10776 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10778 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10779 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10780 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10781 _ckvmssts(sys$dassgn(chan));
10782 if (retsts & 1) retsts = iosb[0];
10783 if (!(retsts & 1)) {
10784 set_vaxc_errno(retsts);
10785 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10786 else set_errno(EVMSERR);
10792 #endif /* #if __CRTL_VER >= 70300000 */
10794 } /* end of my_utime() */
10798 * flex_stat, flex_lstat, flex_fstat
10799 * basic stat, but gets it right when asked to stat
10800 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10803 #ifndef _USE_STD_STAT
10804 /* encode_dev packs a VMS device name string into an integer to allow
10805 * simple comparisons. This can be used, for example, to check whether two
10806 * files are located on the same device, by comparing their encoded device
10807 * names. Even a string comparison would not do, because stat() reuses the
10808 * device name buffer for each call; so without encode_dev, it would be
10809 * necessary to save the buffer and use strcmp (this would mean a number of
10810 * changes to the standard Perl code, to say nothing of what a Perl script
10811 * would have to do.
10813 * The device lock id, if it exists, should be unique (unless perhaps compared
10814 * with lock ids transferred from other nodes). We have a lock id if the disk is
10815 * mounted cluster-wide, which is when we tend to get long (host-qualified)
10816 * device names. Thus we use the lock id in preference, and only if that isn't
10817 * available, do we try to pack the device name into an integer (flagged by
10818 * the sign bit (LOCKID_MASK) being set).
10820 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10821 * name and its encoded form, but it seems very unlikely that we will find
10822 * two files on different disks that share the same encoded device names,
10823 * and even more remote that they will share the same file id (if the test
10824 * is to check for the same file).
10826 * A better method might be to use sys$device_scan on the first call, and to
10827 * search for the device, returning an index into the cached array.
10828 * The number returned would be more intelligible.
10829 * This is probably not worth it, and anyway would take quite a bit longer
10830 * on the first call.
10832 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
10833 static mydev_t encode_dev (pTHX_ const char *dev)
10836 unsigned long int f;
10841 if (!dev || !dev[0]) return 0;
10845 struct dsc$descriptor_s dev_desc;
10846 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10848 /* For cluster-mounted disks, the disk lock identifier is unique, so we
10849 can try that first. */
10850 dev_desc.dsc$w_length = strlen (dev);
10851 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
10852 dev_desc.dsc$b_class = DSC$K_CLASS_S;
10853 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
10854 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10855 if (!$VMS_STATUS_SUCCESS(status)) {
10857 case SS$_NOSUCHDEV:
10858 SETERRNO(ENODEV, status);
10864 if (lockid) return (lockid & ~LOCKID_MASK);
10868 /* Otherwise we try to encode the device name */
10872 for (q = dev + strlen(dev); q--; q >= dev) {
10877 else if (isalpha (toupper (*q)))
10878 c= toupper (*q) - 'A' + (char)10;
10880 continue; /* Skip '$'s */
10882 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
10884 enc += f * (unsigned long int) c;
10886 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
10888 } /* end of encode_dev() */
10889 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10890 device_no = encode_dev(aTHX_ devname)
10892 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10893 device_no = new_dev_no
10897 is_null_device(name)
10900 if (decc_bug_devnull != 0) {
10901 if (strncmp("/dev/null", name, 9) == 0)
10904 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10905 The underscore prefix, controller letter, and unit number are
10906 independently optional; for our purposes, the colon punctuation
10907 is not. The colon can be trailed by optional directory and/or
10908 filename, but two consecutive colons indicates a nodename rather
10909 than a device. [pr] */
10910 if (*name == '_') ++name;
10911 if (tolower(*name++) != 'n') return 0;
10912 if (tolower(*name++) != 'l') return 0;
10913 if (tolower(*name) == 'a') ++name;
10914 if (*name == '0') ++name;
10915 return (*name++ == ':') && (*name != ':');
10920 Perl_cando_by_name_int
10921 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10923 static char usrname[L_cuserid];
10924 static struct dsc$descriptor_s usrdsc =
10925 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10926 char vmsname[NAM$C_MAXRSS+1];
10928 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10929 unsigned short int retlen, trnlnm_iter_count;
10930 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10931 union prvdef curprv;
10932 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10933 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10934 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10935 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10936 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10938 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10940 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10942 if (!fname || !*fname) return FALSE;
10943 /* Make sure we expand logical names, since sys$check_access doesn't */
10946 if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10947 fileified = PerlMem_malloc(VMS_MAXRSS);
10948 if (!strpbrk(fname,"/]>:")) {
10949 strcpy(fileified,fname);
10950 trnlnm_iter_count = 0;
10951 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10952 trnlnm_iter_count++;
10953 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10957 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10958 PerlMem_free(fileified);
10961 retlen = namdsc.dsc$w_length = strlen(vmsname);
10962 namdsc.dsc$a_pointer = vmsname;
10963 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10964 vmsname[retlen-1] == ':') {
10965 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10966 namdsc.dsc$w_length = strlen(fileified);
10967 namdsc.dsc$a_pointer = fileified;
10971 retlen = namdsc.dsc$w_length = strlen(fname);
10972 namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10976 case S_IXUSR: case S_IXGRP: case S_IXOTH:
10977 access = ARM$M_EXECUTE;
10978 flags = CHP$M_READ;
10980 case S_IRUSR: case S_IRGRP: case S_IROTH:
10981 access = ARM$M_READ;
10982 flags = CHP$M_READ | CHP$M_USEREADALL;
10984 case S_IWUSR: case S_IWGRP: case S_IWOTH:
10985 access = ARM$M_WRITE;
10986 flags = CHP$M_READ | CHP$M_WRITE;
10988 case S_IDUSR: case S_IDGRP: case S_IDOTH:
10989 access = ARM$M_DELETE;
10990 flags = CHP$M_READ | CHP$M_WRITE;
10993 if (fileified != NULL)
10994 PerlMem_free(fileified);
10998 /* Before we call $check_access, create a user profile with the current
10999 * process privs since otherwise it just uses the default privs from the
11000 * UAF and might give false positives or negatives. This only works on
11001 * VMS versions v6.0 and later since that's when sys$create_user_profile
11002 * became available.
11005 /* get current process privs and username */
11006 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11007 _ckvmssts(iosb[0]);
11009 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11011 /* find out the space required for the profile */
11012 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11013 &usrprodsc.dsc$w_length,0));
11015 /* allocate space for the profile and get it filled in */
11016 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11017 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11018 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11019 &usrprodsc.dsc$w_length,0));
11021 /* use the profile to check access to the file; free profile & analyze results */
11022 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
11023 PerlMem_free(usrprodsc.dsc$a_pointer);
11024 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11028 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11032 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
11033 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11034 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11035 set_vaxc_errno(retsts);
11036 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11037 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11038 else set_errno(ENOENT);
11039 if (fileified != NULL)
11040 PerlMem_free(fileified);
11043 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11044 if (fileified != NULL)
11045 PerlMem_free(fileified);
11050 if (fileified != NULL)
11051 PerlMem_free(fileified);
11052 return FALSE; /* Should never get here */
11056 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
11057 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11058 * subset of the applicable information.
11061 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11063 return cando_by_name_int
11064 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11065 } /* end of cando() */
11069 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11071 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11073 return cando_by_name_int(bit, effective, fname, 0);
11075 } /* end of cando_by_name() */
11079 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11081 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11083 if (!fstat(fd,(stat_t *) statbufp)) {
11085 char *vms_filename;
11086 vms_filename = PerlMem_malloc(VMS_MAXRSS);
11087 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11089 /* Save name for cando by name in VMS format */
11090 cptr = getname(fd, vms_filename, 1);
11092 /* This should not happen, but just in case */
11093 if (cptr == NULL) {
11094 statbufp->st_devnam[0] = 0;
11097 /* Make sure that the saved name fits in 255 characters */
11098 cptr = do_rmsexpand
11100 statbufp->st_devnam,
11103 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11107 statbufp->st_devnam[0] = 0;
11109 PerlMem_free(vms_filename);
11111 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11113 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11115 # ifdef RTL_USES_UTC
11116 # ifdef VMSISH_TIME
11118 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11119 statbufp->st_atime = _toloc(statbufp->st_atime);
11120 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11124 # ifdef VMSISH_TIME
11125 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11129 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11130 statbufp->st_atime = _toutc(statbufp->st_atime);
11131 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11138 } /* end of flex_fstat() */
11141 #if !defined(__VAX) && __CRTL_VER >= 80200000
11149 #define lstat(_x, _y) stat(_x, _y)
11152 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11155 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11157 char fileified[VMS_MAXRSS];
11158 char temp_fspec[VMS_MAXRSS];
11161 int saved_errno, saved_vaxc_errno;
11163 if (!fspec) return retval;
11164 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11165 strcpy(temp_fspec, fspec);
11167 if (decc_bug_devnull != 0) {
11168 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11169 memset(statbufp,0,sizeof *statbufp);
11170 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11171 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11172 statbufp->st_uid = 0x00010001;
11173 statbufp->st_gid = 0x0001;
11174 time((time_t *)&statbufp->st_mtime);
11175 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11180 /* Try for a directory name first. If fspec contains a filename without
11181 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11182 * and sea:[wine.dark]water. exist, we prefer the directory here.
11183 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11184 * not sea:[wine.dark]., if the latter exists. If the intended target is
11185 * the file with null type, specify this by calling flex_stat() with
11186 * a '.' at the end of fspec.
11188 * If we are in Posix filespec mode, accept the filename as is.
11190 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11191 if (decc_posix_compliant_pathnames == 0) {
11193 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11194 if (lstat_flag == 0)
11195 retval = stat(fileified,(stat_t *) statbufp);
11197 retval = lstat(fileified,(stat_t *) statbufp);
11198 save_spec = fileified;
11201 if (lstat_flag == 0)
11202 retval = stat(temp_fspec,(stat_t *) statbufp);
11204 retval = lstat(temp_fspec,(stat_t *) statbufp);
11205 save_spec = temp_fspec;
11207 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11209 if (lstat_flag == 0)
11210 retval = stat(temp_fspec,(stat_t *) statbufp);
11212 retval = lstat(temp_fspec,(stat_t *) statbufp);
11213 save_spec = temp_fspec;
11218 cptr = do_rmsexpand
11219 (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11221 statbufp->st_devnam[0] = 0;
11223 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11225 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11226 # ifdef RTL_USES_UTC
11227 # ifdef VMSISH_TIME
11229 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11230 statbufp->st_atime = _toloc(statbufp->st_atime);
11231 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11235 # ifdef VMSISH_TIME
11236 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11240 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11241 statbufp->st_atime = _toutc(statbufp->st_atime);
11242 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11246 /* If we were successful, leave errno where we found it */
11247 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11250 } /* end of flex_stat_int() */
11253 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11255 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11257 return flex_stat_int(fspec, statbufp, 0);
11261 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11263 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11265 return flex_stat_int(fspec, statbufp, 1);
11270 /*{{{char *my_getlogin()*/
11271 /* VMS cuserid == Unix getlogin, except calling sequence */
11275 static char user[L_cuserid];
11276 return cuserid(user);
11281 /* rmscopy - copy a file using VMS RMS routines
11283 * Copies contents and attributes of spec_in to spec_out, except owner
11284 * and protection information. Name and type of spec_in are used as
11285 * defaults for spec_out. The third parameter specifies whether rmscopy()
11286 * should try to propagate timestamps from the input file to the output file.
11287 * If it is less than 0, no timestamps are preserved. If it is 0, then
11288 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
11289 * propagated to the output file at creation iff the output file specification
11290 * did not contain an explicit name or type, and the revision date is always
11291 * updated at the end of the copy operation. If it is greater than 0, then
11292 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11293 * other than the revision date should be propagated, and bit 1 indicates
11294 * that the revision date should be propagated.
11296 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11298 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11299 * Incorporates, with permission, some code from EZCOPY by Tim Adye
11300 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
11301 * as part of the Perl standard distribution under the terms of the
11302 * GNU General Public License or the Perl Artistic License. Copies
11303 * of each may be found in the Perl standard distribution.
11305 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11307 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11309 char *vmsin, * vmsout, *esa, *esa_out,
11311 unsigned long int i, sts, sts2;
11313 struct FAB fab_in, fab_out;
11314 struct RAB rab_in, rab_out;
11315 rms_setup_nam(nam);
11316 rms_setup_nam(nam_out);
11317 struct XABDAT xabdat;
11318 struct XABFHC xabfhc;
11319 struct XABRDT xabrdt;
11320 struct XABSUM xabsum;
11322 vmsin = PerlMem_malloc(VMS_MAXRSS);
11323 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11324 vmsout = PerlMem_malloc(VMS_MAXRSS);
11325 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11326 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11327 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11328 PerlMem_free(vmsin);
11329 PerlMem_free(vmsout);
11330 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11334 esa = PerlMem_malloc(VMS_MAXRSS);
11335 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11336 fab_in = cc$rms_fab;
11337 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11338 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11339 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11340 fab_in.fab$l_fop = FAB$M_SQO;
11341 rms_bind_fab_nam(fab_in, nam);
11342 fab_in.fab$l_xab = (void *) &xabdat;
11344 rsa = PerlMem_malloc(VMS_MAXRSS);
11345 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11346 rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11347 rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11348 rms_nam_esl(nam) = 0;
11349 rms_nam_rsl(nam) = 0;
11350 rms_nam_esll(nam) = 0;
11351 rms_nam_rsll(nam) = 0;
11352 #ifdef NAM$M_NO_SHORT_UPCASE
11353 if (decc_efs_case_preserve)
11354 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11357 xabdat = cc$rms_xabdat; /* To get creation date */
11358 xabdat.xab$l_nxt = (void *) &xabfhc;
11360 xabfhc = cc$rms_xabfhc; /* To get record length */
11361 xabfhc.xab$l_nxt = (void *) &xabsum;
11363 xabsum = cc$rms_xabsum; /* To get key and area information */
11365 if (!((sts = sys$open(&fab_in)) & 1)) {
11366 PerlMem_free(vmsin);
11367 PerlMem_free(vmsout);
11370 set_vaxc_errno(sts);
11372 case RMS$_FNF: case RMS$_DNF:
11373 set_errno(ENOENT); break;
11375 set_errno(ENOTDIR); break;
11377 set_errno(ENODEV); break;
11379 set_errno(EINVAL); break;
11381 set_errno(EACCES); break;
11383 set_errno(EVMSERR);
11390 fab_out.fab$w_ifi = 0;
11391 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11392 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11393 fab_out.fab$l_fop = FAB$M_SQO;
11394 rms_bind_fab_nam(fab_out, nam_out);
11395 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11396 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11397 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11398 esa_out = PerlMem_malloc(VMS_MAXRSS);
11399 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11400 rms_set_rsa(nam_out, NULL, 0);
11401 rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11403 if (preserve_dates == 0) { /* Act like DCL COPY */
11404 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11405 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
11406 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11407 PerlMem_free(vmsin);
11408 PerlMem_free(vmsout);
11411 PerlMem_free(esa_out);
11412 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11413 set_vaxc_errno(sts);
11416 fab_out.fab$l_xab = (void *) &xabdat;
11417 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11418 preserve_dates = 1;
11420 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
11421 preserve_dates =0; /* bitmask from this point forward */
11423 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11424 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11425 PerlMem_free(vmsin);
11426 PerlMem_free(vmsout);
11429 PerlMem_free(esa_out);
11430 set_vaxc_errno(sts);
11433 set_errno(ENOENT); break;
11435 set_errno(ENOTDIR); break;
11437 set_errno(ENODEV); break;
11439 set_errno(EINVAL); break;
11441 set_errno(EACCES); break;
11443 set_errno(EVMSERR);
11447 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
11448 if (preserve_dates & 2) {
11449 /* sys$close() will process xabrdt, not xabdat */
11450 xabrdt = cc$rms_xabrdt;
11452 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11454 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11455 * is unsigned long[2], while DECC & VAXC use a struct */
11456 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11458 fab_out.fab$l_xab = (void *) &xabrdt;
11461 ubf = PerlMem_malloc(32256);
11462 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11463 rab_in = cc$rms_rab;
11464 rab_in.rab$l_fab = &fab_in;
11465 rab_in.rab$l_rop = RAB$M_BIO;
11466 rab_in.rab$l_ubf = ubf;
11467 rab_in.rab$w_usz = 32256;
11468 if (!((sts = sys$connect(&rab_in)) & 1)) {
11469 sys$close(&fab_in); sys$close(&fab_out);
11470 PerlMem_free(vmsin);
11471 PerlMem_free(vmsout);
11475 PerlMem_free(esa_out);
11476 set_errno(EVMSERR); set_vaxc_errno(sts);
11480 rab_out = cc$rms_rab;
11481 rab_out.rab$l_fab = &fab_out;
11482 rab_out.rab$l_rbf = ubf;
11483 if (!((sts = sys$connect(&rab_out)) & 1)) {
11484 sys$close(&fab_in); sys$close(&fab_out);
11485 PerlMem_free(vmsin);
11486 PerlMem_free(vmsout);
11490 PerlMem_free(esa_out);
11491 set_errno(EVMSERR); set_vaxc_errno(sts);
11495 while ((sts = sys$read(&rab_in))) { /* always true */
11496 if (sts == RMS$_EOF) break;
11497 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11498 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11499 sys$close(&fab_in); sys$close(&fab_out);
11500 PerlMem_free(vmsin);
11501 PerlMem_free(vmsout);
11505 PerlMem_free(esa_out);
11506 set_errno(EVMSERR); set_vaxc_errno(sts);
11512 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
11513 sys$close(&fab_in); sys$close(&fab_out);
11514 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11516 PerlMem_free(vmsin);
11517 PerlMem_free(vmsout);
11521 PerlMem_free(esa_out);
11522 set_errno(EVMSERR); set_vaxc_errno(sts);
11526 PerlMem_free(vmsin);
11527 PerlMem_free(vmsout);
11531 PerlMem_free(esa_out);
11534 } /* end of rmscopy() */
11538 /*** The following glue provides 'hooks' to make some of the routines
11539 * from this file available from Perl. These routines are sufficiently
11540 * basic, and are required sufficiently early in the build process,
11541 * that's it's nice to have them available to miniperl as well as the
11542 * full Perl, so they're set up here instead of in an extension. The
11543 * Perl code which handles importation of these names into a given
11544 * package lives in [.VMS]Filespec.pm in @INC.
11548 rmsexpand_fromperl(pTHX_ CV *cv)
11551 char *fspec, *defspec = NULL, *rslt;
11553 int fs_utf8, dfs_utf8;
11557 if (!items || items > 2)
11558 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11559 fspec = SvPV(ST(0),n_a);
11560 fs_utf8 = SvUTF8(ST(0));
11561 if (!fspec || !*fspec) XSRETURN_UNDEF;
11563 defspec = SvPV(ST(1),n_a);
11564 dfs_utf8 = SvUTF8(ST(1));
11566 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11567 ST(0) = sv_newmortal();
11568 if (rslt != NULL) {
11569 sv_usepvn(ST(0),rslt,strlen(rslt));
11578 vmsify_fromperl(pTHX_ CV *cv)
11585 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11586 utf8_fl = SvUTF8(ST(0));
11587 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11588 ST(0) = sv_newmortal();
11589 if (vmsified != NULL) {
11590 sv_usepvn(ST(0),vmsified,strlen(vmsified));
11599 unixify_fromperl(pTHX_ CV *cv)
11606 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11607 utf8_fl = SvUTF8(ST(0));
11608 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11609 ST(0) = sv_newmortal();
11610 if (unixified != NULL) {
11611 sv_usepvn(ST(0),unixified,strlen(unixified));
11620 fileify_fromperl(pTHX_ CV *cv)
11627 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11628 utf8_fl = SvUTF8(ST(0));
11629 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11630 ST(0) = sv_newmortal();
11631 if (fileified != NULL) {
11632 sv_usepvn(ST(0),fileified,strlen(fileified));
11641 pathify_fromperl(pTHX_ CV *cv)
11648 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11649 utf8_fl = SvUTF8(ST(0));
11650 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11651 ST(0) = sv_newmortal();
11652 if (pathified != NULL) {
11653 sv_usepvn(ST(0),pathified,strlen(pathified));
11662 vmspath_fromperl(pTHX_ CV *cv)
11669 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11670 utf8_fl = SvUTF8(ST(0));
11671 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11672 ST(0) = sv_newmortal();
11673 if (vmspath != NULL) {
11674 sv_usepvn(ST(0),vmspath,strlen(vmspath));
11683 unixpath_fromperl(pTHX_ CV *cv)
11690 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11691 utf8_fl = SvUTF8(ST(0));
11692 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11693 ST(0) = sv_newmortal();
11694 if (unixpath != NULL) {
11695 sv_usepvn(ST(0),unixpath,strlen(unixpath));
11704 candelete_fromperl(pTHX_ CV *cv)
11712 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11714 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11715 Newx(fspec, VMS_MAXRSS, char);
11716 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11717 if (SvTYPE(mysv) == SVt_PVGV) {
11718 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11719 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11727 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11728 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11735 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11741 rmscopy_fromperl(pTHX_ CV *cv)
11744 char *inspec, *outspec, *inp, *outp;
11746 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11747 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11748 unsigned long int sts;
11753 if (items < 2 || items > 3)
11754 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11756 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11757 Newx(inspec, VMS_MAXRSS, char);
11758 if (SvTYPE(mysv) == SVt_PVGV) {
11759 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11760 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11768 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11769 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11775 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11776 Newx(outspec, VMS_MAXRSS, char);
11777 if (SvTYPE(mysv) == SVt_PVGV) {
11778 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11779 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11788 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11789 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11796 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11798 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11804 /* The mod2fname is limited to shorter filenames by design, so it should
11805 * not be modified to support longer EFS pathnames
11808 mod2fname(pTHX_ CV *cv)
11811 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11812 workbuff[NAM$C_MAXRSS*1 + 1];
11813 int total_namelen = 3, counter, num_entries;
11814 /* ODS-5 ups this, but we want to be consistent, so... */
11815 int max_name_len = 39;
11816 AV *in_array = (AV *)SvRV(ST(0));
11818 num_entries = av_len(in_array);
11820 /* All the names start with PL_. */
11821 strcpy(ultimate_name, "PL_");
11823 /* Clean up our working buffer */
11824 Zero(work_name, sizeof(work_name), char);
11826 /* Run through the entries and build up a working name */
11827 for(counter = 0; counter <= num_entries; counter++) {
11828 /* If it's not the first name then tack on a __ */
11830 strcat(work_name, "__");
11832 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11836 /* Check to see if we actually have to bother...*/
11837 if (strlen(work_name) + 3 <= max_name_len) {
11838 strcat(ultimate_name, work_name);
11840 /* It's too darned big, so we need to go strip. We use the same */
11841 /* algorithm as xsubpp does. First, strip out doubled __ */
11842 char *source, *dest, last;
11845 for (source = work_name; *source; source++) {
11846 if (last == *source && last == '_') {
11852 /* Go put it back */
11853 strcpy(work_name, workbuff);
11854 /* Is it still too big? */
11855 if (strlen(work_name) + 3 > max_name_len) {
11856 /* Strip duplicate letters */
11859 for (source = work_name; *source; source++) {
11860 if (last == toupper(*source)) {
11864 last = toupper(*source);
11866 strcpy(work_name, workbuff);
11869 /* Is it *still* too big? */
11870 if (strlen(work_name) + 3 > max_name_len) {
11871 /* Too bad, we truncate */
11872 work_name[max_name_len - 2] = 0;
11874 strcat(ultimate_name, work_name);
11877 /* Okay, return it */
11878 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11883 hushexit_fromperl(pTHX_ CV *cv)
11888 VMSISH_HUSHED = SvTRUE(ST(0));
11890 ST(0) = boolSV(VMSISH_HUSHED);
11896 Perl_vms_start_glob
11897 (pTHX_ SV *tmpglob,
11901 struct vs_str_st *rslt;
11905 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11908 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11909 struct dsc$descriptor_vs rsdsc;
11910 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11911 unsigned long hasver = 0, isunix = 0;
11912 unsigned long int lff_flags = 0;
11915 #ifdef VMS_LONGNAME_SUPPORT
11916 lff_flags = LIB$M_FIL_LONG_NAMES;
11918 /* The Newx macro will not allow me to assign a smaller array
11919 * to the rslt pointer, so we will assign it to the begin char pointer
11920 * and then copy the value into the rslt pointer.
11922 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11923 rslt = (struct vs_str_st *)begin;
11925 rstr = &rslt->str[0];
11926 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11927 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11928 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11929 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11931 Newx(vmsspec, VMS_MAXRSS, char);
11933 /* We could find out if there's an explicit dev/dir or version
11934 by peeking into lib$find_file's internal context at
11935 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11936 but that's unsupported, so I don't want to do it now and
11937 have it bite someone in the future. */
11938 /* Fix-me: vms_split_path() is the only way to do this, the
11939 existing method will fail with many legal EFS or UNIX specifications
11942 cp = SvPV(tmpglob,i);
11945 if (cp[i] == ';') hasver = 1;
11946 if (cp[i] == '.') {
11947 if (sts) hasver = 1;
11950 if (cp[i] == '/') {
11951 hasdir = isunix = 1;
11954 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11959 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11962 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11963 if (!stat_sts && S_ISDIR(st.st_mode)) {
11964 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11965 ok = (wilddsc.dsc$a_pointer != NULL);
11968 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11969 ok = (wilddsc.dsc$a_pointer != NULL);
11972 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11974 /* If not extended character set, replace ? with % */
11975 /* With extended character set, ? is a wildcard single character */
11976 if (!decc_efs_case_preserve) {
11977 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11978 if (*cp == '?') *cp = '%';
11981 while (ok && $VMS_STATUS_SUCCESS(sts)) {
11982 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11983 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11985 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11986 &dfltdsc,NULL,&rms_sts,&lff_flags);
11987 if (!$VMS_STATUS_SUCCESS(sts))
11990 /* with varying string, 1st word of buffer contains result length */
11991 rstr[rslt->length] = '\0';
11993 /* Find where all the components are */
11994 v_sts = vms_split_path
12009 /* If no version on input, truncate the version on output */
12010 if (!hasver && (vs_len > 0)) {
12014 /* No version & a null extension on UNIX handling */
12015 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12021 if (!decc_efs_case_preserve) {
12022 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12026 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12030 /* Start with the name */
12033 strcat(begin,"\n");
12034 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12036 if (cxt) (void)lib$find_file_end(&cxt);
12037 if (ok && sts != RMS$_NMF &&
12038 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12041 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12043 PerlIO_close(tmpfp);
12047 PerlIO_rewind(tmpfp);
12048 IoTYPE(io) = IoTYPE_RDONLY;
12049 IoIFP(io) = fp = tmpfp;
12050 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
12061 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
12064 vms_realpath_fromperl(pTHX_ CV *cv)
12067 char *fspec, *rslt_spec, *rslt;
12070 if (!items || items != 1)
12071 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12073 fspec = SvPV(ST(0),n_a);
12074 if (!fspec || !*fspec) XSRETURN_UNDEF;
12076 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12077 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12078 ST(0) = sv_newmortal();
12080 sv_usepvn(ST(0),rslt,strlen(rslt));
12082 Safefree(rslt_spec);
12087 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12088 int do_vms_case_tolerant(void);
12091 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12094 ST(0) = boolSV(do_vms_case_tolerant());
12100 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12101 struct interp_intern *dst)
12103 memcpy(dst,src,sizeof(struct interp_intern));
12107 Perl_sys_intern_clear(pTHX)
12112 Perl_sys_intern_init(pTHX)
12114 unsigned int ix = RAND_MAX;
12119 /* fix me later to track running under GNV */
12120 /* this allows some limited testing */
12121 MY_POSIX_EXIT = decc_filename_unix_report;
12124 MY_INV_RAND_MAX = 1./x;
12128 init_os_extras(void)
12131 char* file = __FILE__;
12132 if (decc_disable_to_vms_logname_translation) {
12133 no_translate_barewords = TRUE;
12135 no_translate_barewords = FALSE;
12138 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12139 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12140 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12141 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12142 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12143 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12144 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12145 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12146 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12147 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12148 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12150 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12152 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12153 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12156 store_pipelocs(aTHX); /* will redo any earlier attempts */
12163 #if __CRTL_VER == 80200000
12164 /* This missed getting in to the DECC SDK for 8.2 */
12165 char *realpath(const char *file_name, char * resolved_name, ...);
12168 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12169 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12170 * The perl fallback routine to provide realpath() is not as efficient
12174 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12176 return realpath(filespec, outbuf);
12180 /* External entry points */
12181 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12182 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12184 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12189 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12190 /* case_tolerant */
12192 /*{{{int do_vms_case_tolerant(void)*/
12193 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12194 * controlled by a process setting.
12196 int do_vms_case_tolerant(void)
12198 return vms_process_case_tolerant;
12201 /* External entry points */
12202 int Perl_vms_case_tolerant(void)
12203 { return do_vms_case_tolerant(); }
12205 int Perl_vms_case_tolerant(void)
12206 { return vms_process_case_tolerant; }
12210 /* Start of DECC RTL Feature handling */
12212 static int sys_trnlnm
12213 (const char * logname,
12217 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12218 const unsigned long attr = LNM$M_CASE_BLIND;
12219 struct dsc$descriptor_s name_dsc;
12221 unsigned short result;
12222 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12225 name_dsc.dsc$w_length = strlen(logname);
12226 name_dsc.dsc$a_pointer = (char *)logname;
12227 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12228 name_dsc.dsc$b_class = DSC$K_CLASS_S;
12230 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12232 if ($VMS_STATUS_SUCCESS(status)) {
12234 /* Null terminate and return the string */
12235 /*--------------------------------------*/
12242 static int sys_crelnm
12243 (const char * logname,
12244 const char * value)
12247 const char * proc_table = "LNM$PROCESS_TABLE";
12248 struct dsc$descriptor_s proc_table_dsc;
12249 struct dsc$descriptor_s logname_dsc;
12250 struct itmlst_3 item_list[2];
12252 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12253 proc_table_dsc.dsc$w_length = strlen(proc_table);
12254 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12255 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12257 logname_dsc.dsc$a_pointer = (char *) logname;
12258 logname_dsc.dsc$w_length = strlen(logname);
12259 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12260 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12262 item_list[0].buflen = strlen(value);
12263 item_list[0].itmcode = LNM$_STRING;
12264 item_list[0].bufadr = (char *)value;
12265 item_list[0].retlen = NULL;
12267 item_list[1].buflen = 0;
12268 item_list[1].itmcode = 0;
12270 ret_val = sys$crelnm
12272 (const struct dsc$descriptor_s *)&proc_table_dsc,
12273 (const struct dsc$descriptor_s *)&logname_dsc,
12275 (const struct item_list_3 *) item_list);
12280 /* C RTL Feature settings */
12282 static int set_features
12283 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
12284 int (* cli_routine)(void), /* Not documented */
12285 void *image_info) /* Not documented */
12292 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12293 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12294 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12295 unsigned long case_perm;
12296 unsigned long case_image;
12299 /* Allow an exception to bring Perl into the VMS debugger */
12300 vms_debug_on_exception = 0;
12301 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12302 if ($VMS_STATUS_SUCCESS(status)) {
12303 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12304 vms_debug_on_exception = 1;
12306 vms_debug_on_exception = 0;
12309 /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12310 vms_vtf7_filenames = 0;
12311 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12312 if ($VMS_STATUS_SUCCESS(status)) {
12313 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12314 vms_vtf7_filenames = 1;
12316 vms_vtf7_filenames = 0;
12319 /* Dectect running under GNV Bash or other UNIX like shell */
12320 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12321 gnv_unix_shell = 0;
12322 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12323 if ($VMS_STATUS_SUCCESS(status)) {
12324 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12325 gnv_unix_shell = 1;
12326 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12327 set_feature_default("DECC$EFS_CHARSET", 1);
12328 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12329 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12330 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12331 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12334 gnv_unix_shell = 0;
12338 /* hacks to see if known bugs are still present for testing */
12340 /* Readdir is returning filenames in VMS syntax always */
12341 decc_bug_readdir_efs1 = 1;
12342 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12343 if ($VMS_STATUS_SUCCESS(status)) {
12344 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12345 decc_bug_readdir_efs1 = 1;
12347 decc_bug_readdir_efs1 = 0;
12350 /* PCP mode requires creating /dev/null special device file */
12351 decc_bug_devnull = 0;
12352 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12353 if ($VMS_STATUS_SUCCESS(status)) {
12354 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12355 decc_bug_devnull = 1;
12357 decc_bug_devnull = 0;
12360 /* fgetname returning a VMS name in UNIX mode */
12361 decc_bug_fgetname = 1;
12362 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12363 if ($VMS_STATUS_SUCCESS(status)) {
12364 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12365 decc_bug_fgetname = 1;
12367 decc_bug_fgetname = 0;
12370 /* UNIX directory names with no paths are broken in a lot of places */
12371 decc_dir_barename = 1;
12372 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12373 if ($VMS_STATUS_SUCCESS(status)) {
12374 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12375 decc_dir_barename = 1;
12377 decc_dir_barename = 0;
12380 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12381 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12383 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12384 if (decc_disable_to_vms_logname_translation < 0)
12385 decc_disable_to_vms_logname_translation = 0;
12388 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12390 decc_efs_case_preserve = decc$feature_get_value(s, 1);
12391 if (decc_efs_case_preserve < 0)
12392 decc_efs_case_preserve = 0;
12395 s = decc$feature_get_index("DECC$EFS_CHARSET");
12397 decc_efs_charset = decc$feature_get_value(s, 1);
12398 if (decc_efs_charset < 0)
12399 decc_efs_charset = 0;
12402 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12404 decc_filename_unix_report = decc$feature_get_value(s, 1);
12405 if (decc_filename_unix_report > 0)
12406 decc_filename_unix_report = 1;
12408 decc_filename_unix_report = 0;
12411 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12413 decc_filename_unix_only = decc$feature_get_value(s, 1);
12414 if (decc_filename_unix_only > 0) {
12415 decc_filename_unix_only = 1;
12418 decc_filename_unix_only = 0;
12422 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12424 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12425 if (decc_filename_unix_no_version < 0)
12426 decc_filename_unix_no_version = 0;
12429 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12431 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12432 if (decc_readdir_dropdotnotype < 0)
12433 decc_readdir_dropdotnotype = 0;
12436 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12437 if ($VMS_STATUS_SUCCESS(status)) {
12438 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12440 dflt = decc$feature_get_value(s, 4);
12442 decc_disable_posix_root = decc$feature_get_value(s, 1);
12443 if (decc_disable_posix_root <= 0) {
12444 decc$feature_set_value(s, 1, 1);
12445 decc_disable_posix_root = 1;
12449 /* Traditionally Perl assumes this is off */
12450 decc_disable_posix_root = 1;
12451 decc$feature_set_value(s, 1, 1);
12456 #if __CRTL_VER >= 80200000
12457 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12459 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12460 if (decc_posix_compliant_pathnames < 0)
12461 decc_posix_compliant_pathnames = 0;
12462 if (decc_posix_compliant_pathnames > 4)
12463 decc_posix_compliant_pathnames = 0;
12468 status = sys_trnlnm
12469 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12470 if ($VMS_STATUS_SUCCESS(status)) {
12471 val_str[0] = _toupper(val_str[0]);
12472 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12473 decc_disable_to_vms_logname_translation = 1;
12478 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12479 if ($VMS_STATUS_SUCCESS(status)) {
12480 val_str[0] = _toupper(val_str[0]);
12481 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12482 decc_efs_case_preserve = 1;
12487 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", 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_report = 1;
12494 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12495 if ($VMS_STATUS_SUCCESS(status)) {
12496 val_str[0] = _toupper(val_str[0]);
12497 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12498 decc_filename_unix_only = 1;
12499 decc_filename_unix_report = 1;
12502 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", 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_filename_unix_no_version = 1;
12509 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12510 if ($VMS_STATUS_SUCCESS(status)) {
12511 val_str[0] = _toupper(val_str[0]);
12512 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12513 decc_readdir_dropdotnotype = 1;
12518 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12520 /* Report true case tolerance */
12521 /*----------------------------*/
12522 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12523 if (!$VMS_STATUS_SUCCESS(status))
12524 case_perm = PPROP$K_CASE_BLIND;
12525 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12526 if (!$VMS_STATUS_SUCCESS(status))
12527 case_image = PPROP$K_CASE_BLIND;
12528 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12529 (case_image == PPROP$K_CASE_SENSITIVE))
12530 vms_process_case_tolerant = 0;
12535 /* CRTL can be initialized past this point, but not before. */
12536 /* DECC$CRTL_INIT(); */
12543 #pragma extern_model save
12544 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12545 const __align (LONGWORD) int spare[8] = {0};
12547 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
12548 #if __DECC_VER >= 60560002
12549 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
12551 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
12553 #endif /* __DECC */
12555 const long vms_cc_features = (const long)set_features;
12558 ** Force a reference to LIB$INITIALIZE to ensure it
12559 ** exists in the image.
12561 int lib$initialize(void);
12563 #pragma extern_model strict_refdef
12565 int lib_init_ref = (int) lib$initialize;
12568 #pragma extern_model restore