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 */
6097 *(cp1++) = *(++cp2);
6098 /* An escaped dot stays as is -- don't convert to slash */
6099 if (*cp2 == '.') cp2++;
6103 if (*(cp2+1) == '[') cp2++;
6105 else if (*cp2 == ']' || *cp2 == '>') {
6106 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6108 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6110 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6111 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6112 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6113 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6114 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6116 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6117 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6121 else if (*cp2 == '-') {
6122 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6123 while (*cp2 == '-') {
6125 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6127 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6128 if (ts) Safefree(rslt); /* filespecs like */
6129 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
6133 else *(cp1++) = *cp2;
6135 else *(cp1++) = *cp2;
6138 if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */
6139 *(cp1++) = *(cp2++);
6143 /* This still leaves /000000/ when working with a
6144 * VMS device root or concealed root.
6150 ulen = strlen(rslt);
6152 /* Get rid of "000000/ in rooted filespecs */
6154 zeros = strstr(rslt, "/000000/");
6155 if (zeros != NULL) {
6157 mlen = ulen - (zeros - rslt) - 7;
6158 memmove(zeros, &zeros[7], mlen);
6167 } /* end of do_tounixspec() */
6169 /* External entry points */
6170 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6171 { return do_tounixspec(spec,buf,0, NULL); }
6172 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6173 { return do_tounixspec(spec,buf,1, NULL); }
6174 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6175 { return do_tounixspec(spec,buf,0, utf8_fl); }
6176 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6177 { return do_tounixspec(spec,buf,1, utf8_fl); }
6179 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6182 This procedure is used to identify if a path is based in either
6183 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6184 it returns the OpenVMS format directory for it.
6186 It is expecting specifications of only '/' or '/xxxx/'
6188 If a posix root does not exist, or 'xxxx' is not a directory
6189 in the posix root, it returns a failure.
6191 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6193 It is used only internally by posix_to_vmsspec_hardway().
6196 static int posix_root_to_vms
6197 (char *vmspath, int vmspath_len,
6198 const char *unixpath,
6199 const int * utf8_fl) {
6201 struct FAB myfab = cc$rms_fab;
6202 struct NAML mynam = cc$rms_naml;
6203 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6204 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6211 unixlen = strlen(unixpath);
6217 #if __CRTL_VER >= 80200000
6218 /* If not a posix spec already, convert it */
6219 if (decc_posix_compliant_pathnames) {
6220 if (strncmp(unixpath,"\"^UP^",5) != 0) {
6221 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6224 /* This is already a VMS specification, no conversion */
6226 strncpy(vmspath,unixpath, vmspath_len);
6235 /* Check to see if this is under the POSIX root */
6236 if (decc_disable_posix_root) {
6240 /* Skip leading / */
6241 if (unixpath[0] == '/') {
6247 strcpy(vmspath,"SYS$POSIX_ROOT:");
6249 /* If this is only the / , or blank, then... */
6250 if (unixpath[0] == '\0') {
6251 /* by definition, this is the answer */
6255 /* Need to look up a directory */
6259 /* Copy and add '^' escape characters as needed */
6262 while (unixpath[i] != 0) {
6265 j += copy_expand_unix_filename_escape
6266 (&vmspath[j], &unixpath[i], &k, utf8_fl);
6270 path_len = strlen(vmspath);
6271 if (vmspath[path_len - 1] == '/')
6273 vmspath[path_len] = ']';
6275 vmspath[path_len] = '\0';
6278 vmspath[vmspath_len] = 0;
6279 if (unixpath[unixlen - 1] == '/')
6281 esa = PerlMem_malloc(VMS_MAXRSS);
6282 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6283 myfab.fab$l_fna = vmspath;
6284 myfab.fab$b_fns = strlen(vmspath);
6285 myfab.fab$l_naml = &mynam;
6286 mynam.naml$l_esa = NULL;
6287 mynam.naml$b_ess = 0;
6288 mynam.naml$l_long_expand = esa;
6289 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6290 mynam.naml$l_rsa = NULL;
6291 mynam.naml$b_rss = 0;
6292 if (decc_efs_case_preserve)
6293 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6294 #ifdef NAML$M_OPEN_SPECIAL
6295 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6298 /* Set up the remaining naml fields */
6299 sts = sys$parse(&myfab);
6301 /* It failed! Try again as a UNIX filespec */
6307 /* get the Device ID and the FID */
6308 sts = sys$search(&myfab);
6309 /* on any failure, returned the POSIX ^UP^ filespec */
6314 specdsc.dsc$a_pointer = vmspath;
6315 specdsc.dsc$w_length = vmspath_len;
6317 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6318 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6319 sts = lib$fid_to_name
6320 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6322 /* on any failure, returned the POSIX ^UP^ filespec */
6324 /* This can happen if user does not have permission to read directories */
6325 if (strncmp(unixpath,"\"^UP^",5) != 0)
6326 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6328 strcpy(vmspath, unixpath);
6331 vmspath[specdsc.dsc$w_length] = 0;
6333 /* Are we expecting a directory? */
6334 if (dir_flag != 0) {
6340 i = specdsc.dsc$w_length - 1;
6344 /* Version must be '1' */
6345 if (vmspath[i--] != '1')
6347 /* Version delimiter is one of ".;" */
6348 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6351 if (vmspath[i--] != 'R')
6353 if (vmspath[i--] != 'I')
6355 if (vmspath[i--] != 'D')
6357 if (vmspath[i--] != '.')
6359 eptr = &vmspath[i+1];
6361 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6362 if (vmspath[i-1] != '^') {
6370 /* Get rid of 6 imaginary zero directory filename */
6371 vmspath[i+1] = '\0';
6375 if (vmspath[i] == '0')
6389 /* /dev/mumble needs to be handled special.
6390 /dev/null becomes NLA0:, And there is the potential for other stuff
6391 like /dev/tty which may need to be mapped to something.
6395 slash_dev_special_to_vms
6396 (const char * unixptr,
6406 nextslash = strchr(unixptr, '/');
6407 len = strlen(unixptr);
6408 if (nextslash != NULL)
6409 len = nextslash - unixptr;
6410 cmp = strncmp("null", unixptr, 5);
6412 if (vmspath_len >= 6) {
6413 strcpy(vmspath, "_NLA0:");
6420 /* The built in routines do not understand perl's special needs, so
6421 doing a manual conversion from UNIX to VMS
6423 If the utf8_fl is not null and points to a non-zero value, then
6424 treat 8 bit characters as UTF-8.
6426 The sequence starting with '$(' and ending with ')' will be passed
6427 through with out interpretation instead of being escaped.
6430 static int posix_to_vmsspec_hardway
6431 (char *vmspath, int vmspath_len,
6432 const char *unixpath,
6437 const char *unixptr;
6438 const char *unixend;
6440 const char *lastslash;
6441 const char *lastdot;
6447 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6448 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6450 if (utf8_fl != NULL)
6456 /* Ignore leading "/" characters */
6457 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6460 unixlen = strlen(unixptr);
6462 /* Do nothing with blank paths */
6469 /* This could have a "^UP^ on the front */
6470 if (strncmp(unixptr,"\"^UP^",5) == 0) {
6476 lastslash = strrchr(unixptr,'/');
6477 lastdot = strrchr(unixptr,'.');
6478 unixend = strrchr(unixptr,'\"');
6479 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6480 unixend = unixptr + unixlen;
6483 /* last dot is last dot or past end of string */
6484 if (lastdot == NULL)
6485 lastdot = unixptr + unixlen;
6487 /* if no directories, set last slash to beginning of string */
6488 if (lastslash == NULL) {
6489 lastslash = unixptr;
6492 /* Watch out for trailing "." after last slash, still a directory */
6493 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6494 lastslash = unixptr + unixlen;
6497 /* Watch out for traiing ".." after last slash, still a directory */
6498 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6499 lastslash = unixptr + unixlen;
6502 /* dots in directories are aways escaped */
6503 if (lastdot < lastslash)
6504 lastdot = unixptr + unixlen;
6507 /* if (unixptr < lastslash) then we are in a directory */
6514 /* Start with the UNIX path */
6515 if (*unixptr != '/') {
6516 /* relative paths */
6518 /* If allowing logical names on relative pathnames, then handle here */
6519 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6520 !decc_posix_compliant_pathnames) {
6526 /* Find the next slash */
6527 nextslash = strchr(unixptr,'/');
6529 esa = PerlMem_malloc(vmspath_len);
6530 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6532 trn = PerlMem_malloc(VMS_MAXRSS);
6533 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6535 if (nextslash != NULL) {
6537 seg_len = nextslash - unixptr;
6538 strncpy(esa, unixptr, seg_len);
6542 strcpy(esa, unixptr);
6543 seg_len = strlen(unixptr);
6545 /* trnlnm(section) */
6546 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6549 /* Now fix up the directory */
6551 /* Split up the path to find the components */
6552 sts = vms_split_path
6571 /* A logical name must be a directory or the full
6572 specification. It is only a full specification if
6573 it is the only component */
6574 if ((unixptr[seg_len] == '\0') ||
6575 (unixptr[seg_len+1] == '\0')) {
6577 /* Is a directory being required? */
6578 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6579 /* Not a logical name */
6584 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6585 /* This must be a directory */
6586 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6587 strcpy(vmsptr, esa);
6588 vmslen=strlen(vmsptr);
6589 vmsptr[vmslen] = ':';
6591 vmsptr[vmslen] = '\0';
6599 /* must be dev/directory - ignore version */
6600 if ((n_len + e_len) != 0)
6603 /* transfer the volume */
6604 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6605 strncpy(vmsptr, v_spec, v_len);
6611 /* unroot the rooted directory */
6612 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6614 r_spec[r_len - 1] = ']';
6616 /* This should not be there, but nothing is perfect */
6618 cmp = strcmp(&r_spec[1], "000000.");
6628 strncpy(vmsptr, r_spec, r_len);
6634 /* Bring over the directory. */
6636 ((d_len + vmslen) < vmspath_len)) {
6638 d_spec[d_len - 1] = ']';
6640 cmp = strcmp(&d_spec[1], "000000.");
6651 /* Remove the redundant root */
6659 strncpy(vmsptr, d_spec, d_len);
6673 if (lastslash > unixptr) {
6676 /* skip leading ./ */
6678 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6684 /* Are we still in a directory? */
6685 if (unixptr <= lastslash) {
6690 /* if not backing up, then it is relative forward. */
6691 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6692 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6700 /* Perl wants an empty directory here to tell the difference
6701 * between a DCL commmand and a filename
6710 /* Handle two special files . and .. */
6711 if (unixptr[0] == '.') {
6712 if (&unixptr[1] == unixend) {
6719 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6730 else { /* Absolute PATH handling */
6734 /* Need to find out where root is */
6736 /* In theory, this procedure should never get an absolute POSIX pathname
6737 * that can not be found on the POSIX root.
6738 * In practice, that can not be relied on, and things will show up
6739 * here that are a VMS device name or concealed logical name instead.
6740 * So to make things work, this procedure must be tolerant.
6742 esa = PerlMem_malloc(vmspath_len);
6743 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6746 nextslash = strchr(&unixptr[1],'/');
6748 if (nextslash != NULL) {
6750 seg_len = nextslash - &unixptr[1];
6751 strncpy(vmspath, unixptr, seg_len + 1);
6752 vmspath[seg_len+1] = 0;
6755 cmp = strncmp(vmspath, "dev", 4);
6757 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6758 if (sts = SS$_NORMAL)
6762 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6765 if ($VMS_STATUS_SUCCESS(sts)) {
6766 /* This is verified to be a real path */
6768 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6769 if ($VMS_STATUS_SUCCESS(sts)) {
6770 strcpy(vmspath, esa);
6771 vmslen = strlen(vmspath);
6772 vmsptr = vmspath + vmslen;
6774 if (unixptr < lastslash) {
6783 cmp = strcmp(rptr,"000000.");
6788 } /* removing 6 zeros */
6789 } /* vmslen < 7, no 6 zeros possible */
6790 } /* Not in a directory */
6791 } /* Posix root found */
6793 /* No posix root, fall back to default directory */
6794 strcpy(vmspath, "SYS$DISK:[");
6795 vmsptr = &vmspath[10];
6797 if (unixptr > lastslash) {
6806 } /* end of verified real path handling */
6811 /* Ok, we have a device or a concealed root that is not in POSIX
6812 * or we have garbage. Make the best of it.
6815 /* Posix to VMS destroyed this, so copy it again */
6816 strncpy(vmspath, &unixptr[1], seg_len);
6817 vmspath[seg_len] = 0;
6819 vmsptr = &vmsptr[vmslen];
6822 /* Now do we need to add the fake 6 zero directory to it? */
6824 if ((*lastslash == '/') && (nextslash < lastslash)) {
6825 /* No there is another directory */
6832 /* now we have foo:bar or foo:[000000]bar to decide from */
6833 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6835 if (!islnm && !decc_posix_compliant_pathnames) {
6837 cmp = strncmp("bin", vmspath, 4);
6839 /* bin => SYS$SYSTEM: */
6840 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6843 /* tmp => SYS$SCRATCH: */
6844 cmp = strncmp("tmp", vmspath, 4);
6846 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6851 trnend = islnm ? islnm - 1 : 0;
6853 /* if this was a logical name, ']' or '>' must be present */
6854 /* if not a logical name, then assume a device and hope. */
6855 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6857 /* if log name and trailing '.' then rooted - treat as device */
6858 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6860 /* Fix me, if not a logical name, a device lookup should be
6861 * done to see if the device is file structured. If the device
6862 * is not file structured, the 6 zeros should not be put on.
6864 * As it is, perl is occasionally looking for dev:[000000]tty.
6865 * which looks a little strange.
6867 * Not that easy to detect as "/dev" may be file structured with
6868 * special device files.
6871 if ((add_6zero == 0) && (*nextslash == '/') &&
6872 (&nextslash[1] == unixend)) {
6873 /* No real directory present */
6878 /* Put the device delimiter on */
6881 unixptr = nextslash;
6884 /* Start directory if needed */
6885 if (!islnm || add_6zero) {
6891 /* add fake 000000] if needed */
6904 } /* non-POSIX translation */
6906 } /* End of relative/absolute path handling */
6908 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6915 if (dir_start != 0) {
6917 /* First characters in a directory are handled special */
6918 while ((*unixptr == '/') ||
6919 ((*unixptr == '.') &&
6920 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6921 (&unixptr[1]==unixend)))) {
6926 /* Skip redundant / in specification */
6927 while ((*unixptr == '/') && (dir_start != 0)) {
6930 if (unixptr == lastslash)
6933 if (unixptr == lastslash)
6936 /* Skip redundant ./ characters */
6937 while ((*unixptr == '.') &&
6938 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6941 if (unixptr == lastslash)
6943 if (*unixptr == '/')
6946 if (unixptr == lastslash)
6949 /* Skip redundant ../ characters */
6950 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6951 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6952 /* Set the backing up flag */
6958 unixptr++; /* first . */
6959 unixptr++; /* second . */
6960 if (unixptr == lastslash)
6962 if (*unixptr == '/') /* The slash */
6965 if (unixptr == lastslash)
6968 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6969 /* Not needed when VMS is pretending to be UNIX. */
6971 /* Is this loop stuck because of too many dots? */
6972 if (loop_flag == 0) {
6973 /* Exit the loop and pass the rest through */
6978 /* Are we done with directories yet? */
6979 if (unixptr >= lastslash) {
6981 /* Watch out for trailing dots */
6990 if (*unixptr == '/')
6994 /* Have we stopped backing up? */
6999 /* dir_start continues to be = 1 */
7001 if (*unixptr == '-') {
7003 *vmsptr++ = *unixptr++;
7007 /* Now are we done with directories yet? */
7008 if (unixptr >= lastslash) {
7010 /* Watch out for trailing dots */
7026 if (unixptr >= unixend)
7029 /* Normal characters - More EFS work probably needed */
7035 /* remove multiple / */
7036 while (unixptr[1] == '/') {
7039 if (unixptr == lastslash) {
7040 /* Watch out for trailing dots */
7052 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7053 /* Not needed when VMS is pretending to be UNIX. */
7057 if (unixptr != unixend)
7062 if ((unixptr < lastdot) || (unixptr < lastslash) ||
7063 (&unixptr[1] == unixend)) {
7069 /* trailing dot ==> '^..' on VMS */
7070 if (unixptr == unixend) {
7078 *vmsptr++ = *unixptr++;
7082 if (quoted && (&unixptr[1] == unixend)) {
7086 in_cnt = copy_expand_unix_filename_escape
7087 (vmsptr, unixptr, &out_cnt, utf8_fl);
7097 in_cnt = copy_expand_unix_filename_escape
7098 (vmsptr, unixptr, &out_cnt, utf8_fl);
7105 /* Make sure directory is closed */
7106 if (unixptr == lastslash) {
7108 vmsptr2 = vmsptr - 1;
7110 if (*vmsptr2 != ']') {
7113 /* directories do not end in a dot bracket */
7114 if (*vmsptr2 == '.') {
7118 if (*vmsptr2 != '^') {
7119 vmsptr--; /* back up over the dot */
7127 /* Add a trailing dot if a file with no extension */
7128 vmsptr2 = vmsptr - 1;
7130 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7131 (*vmsptr2 != ')') && (*lastdot != '.')) {
7142 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7143 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7148 /* If a UTF8 flag is being passed, honor it */
7150 if (utf8_fl != NULL) {
7151 utf8_flag = *utf8_fl;
7156 /* If there is a possibility of UTF8, then if any UTF8 characters
7157 are present, then they must be converted to VTF-7
7159 result = strcpy(rslt, path); /* FIX-ME */
7162 result = strcpy(rslt, path);
7168 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7169 static char *mp_do_tovmsspec
7170 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7171 static char __tovmsspec_retbuf[VMS_MAXRSS];
7172 char *rslt, *dirend;
7177 unsigned long int infront = 0, hasdir = 1;
7180 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7181 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7183 if (path == NULL) return NULL;
7184 rslt_len = VMS_MAXRSS-1;
7185 if (buf) rslt = buf;
7186 else if (ts) Newx(rslt, VMS_MAXRSS, char);
7187 else rslt = __tovmsspec_retbuf;
7189 /* '.' and '..' are "[]" and "[-]" for a quick check */
7190 if (path[0] == '.') {
7191 if (path[1] == '\0') {
7193 if (utf8_flag != NULL)
7198 if (path[1] == '.' && path[2] == '\0') {
7200 if (utf8_flag != NULL)
7207 /* Posix specifications are now a native VMS format */
7208 /*--------------------------------------------------*/
7209 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7210 if (decc_posix_compliant_pathnames) {
7211 if (strncmp(path,"\"^UP^",5) == 0) {
7212 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7218 /* This is really the only way to see if this is already in VMS format */
7219 sts = vms_split_path
7234 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7235 replacement, because the above parse just took care of most of
7236 what is needed to do vmspath when the specification is already
7239 And if it is not already, it is easier to do the conversion as
7240 part of this routine than to call this routine and then work on
7244 /* If VMS punctuation was found, it is already VMS format */
7245 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7246 if (utf8_flag != NULL)
7251 /* Now, what to do with trailing "." cases where there is no
7252 extension? If this is a UNIX specification, and EFS characters
7253 are enabled, then the trailing "." should be converted to a "^.".
7254 But if this was already a VMS specification, then it should be
7257 So in the case of ambiguity, leave the specification alone.
7261 /* If there is a possibility of UTF8, then if any UTF8 characters
7262 are present, then they must be converted to VTF-7
7264 if (utf8_flag != NULL)
7270 dirend = strrchr(path,'/');
7272 if (dirend == NULL) {
7273 /* If we get here with no UNIX directory delimiters, then this is
7274 not a complete file specification, either garbage a UNIX glob
7275 specification that can not be converted to a VMS wildcard, or
7276 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7277 so apparently other programs expect this also.
7279 utf8 flag setting needs to be preserved.
7285 /* If POSIX mode active, handle the conversion */
7286 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7287 if (decc_efs_charset) {
7288 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7293 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
7294 if (!*(dirend+2)) dirend +=2;
7295 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7296 if (decc_efs_charset == 0) {
7297 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7303 lastdot = strrchr(cp2,'.');
7309 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7311 if (decc_disable_posix_root) {
7312 strcpy(rslt,"sys$disk:[000000]");
7315 strcpy(rslt,"sys$posix_root:[000000]");
7317 if (utf8_flag != NULL)
7321 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7323 trndev = PerlMem_malloc(VMS_MAXRSS);
7324 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7325 islnm = my_trnlnm(rslt,trndev,0);
7327 /* DECC special handling */
7329 if (strcmp(rslt,"bin") == 0) {
7330 strcpy(rslt,"sys$system");
7333 islnm = my_trnlnm(rslt,trndev,0);
7335 else if (strcmp(rslt,"tmp") == 0) {
7336 strcpy(rslt,"sys$scratch");
7339 islnm = my_trnlnm(rslt,trndev,0);
7341 else if (!decc_disable_posix_root) {
7342 strcpy(rslt, "sys$posix_root");
7346 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7347 islnm = my_trnlnm(rslt,trndev,0);
7349 else if (strcmp(rslt,"dev") == 0) {
7350 if (strncmp(cp2,"/null", 5) == 0) {
7351 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7352 strcpy(rslt,"NLA0");
7356 islnm = my_trnlnm(rslt,trndev,0);
7362 trnend = islnm ? strlen(trndev) - 1 : 0;
7363 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7364 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7365 /* If the first element of the path is a logical name, determine
7366 * whether it has to be translated so we can add more directories. */
7367 if (!islnm || rooted) {
7370 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7374 if (cp2 != dirend) {
7375 strcpy(rslt,trndev);
7376 cp1 = rslt + trnend;
7383 if (decc_disable_posix_root) {
7389 PerlMem_free(trndev);
7394 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7395 cp2 += 2; /* skip over "./" - it's redundant */
7396 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
7398 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7399 *(cp1++) = '-'; /* "../" --> "-" */
7402 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7403 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7404 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7405 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7408 else if ((cp2 != lastdot) || (lastdot < dirend)) {
7409 /* Escape the extra dots in EFS file specifications */
7412 if (cp2 > dirend) cp2 = dirend;
7414 else *(cp1++) = '.';
7416 for (; cp2 < dirend; cp2++) {
7418 if (*(cp2-1) == '/') continue;
7419 if (*(cp1-1) != '.') *(cp1++) = '.';
7422 else if (!infront && *cp2 == '.') {
7423 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7424 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
7425 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7426 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7427 else if (*(cp1-2) == '[') *(cp1-1) = '-';
7428 else { /* back up over previous directory name */
7430 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7431 if (*(cp1-1) == '[') {
7432 memcpy(cp1,"000000.",7);
7437 if (cp2 == dirend) break;
7439 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7440 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7441 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7442 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7444 *(cp1++) = '.'; /* Simulate trailing '/' */
7445 cp2 += 2; /* for loop will incr this to == dirend */
7447 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
7450 if (decc_efs_charset == 0)
7451 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
7453 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
7459 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
7461 if (decc_efs_charset == 0)
7468 else *(cp1++) = *cp2;
7472 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7473 if (hasdir) *(cp1++) = ']';
7474 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
7475 /* fixme for ODS5 */
7482 if (decc_efs_charset == 0)
7493 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7494 decc_readdir_dropdotnotype) {
7499 /* trailing dot ==> '^..' on VMS */
7506 *(cp1++) = *(cp2++);
7511 /* This could be a macro to be passed through */
7512 *(cp1++) = *(cp2++);
7514 const char * save_cp2;
7518 /* paranoid check */
7524 *(cp1++) = *(cp2++);
7525 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7526 *(cp1++) = *(cp2++);
7527 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7528 *(cp1++) = *(cp2++);
7531 *(cp1++) = *(cp2++);
7535 if (is_macro == 0) {
7536 /* Not really a macro - never mind */
7566 *(cp1++) = *(cp2++);
7569 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7570 * which is wrong. UNIX notation should be ".dir." unless
7571 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7572 * changing this behavior could break more things at this time.
7573 * efs character set effectively does not allow "." to be a version
7574 * delimiter as a further complication about changing this.
7576 if (decc_filename_unix_report != 0) {
7579 *(cp1++) = *(cp2++);
7582 *(cp1++) = *(cp2++);
7585 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7589 /* Fix me for "^]", but that requires making sure that you do
7590 * not back up past the start of the filename
7592 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7597 if (utf8_flag != NULL)
7601 } /* end of do_tovmsspec() */
7603 /* External entry points */
7604 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7605 { return do_tovmsspec(path,buf,0,NULL); }
7606 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7607 { return do_tovmsspec(path,buf,1,NULL); }
7608 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7609 { return do_tovmsspec(path,buf,0,utf8_fl); }
7610 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7611 { return do_tovmsspec(path,buf,1,utf8_fl); }
7613 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7614 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7615 static char __tovmspath_retbuf[VMS_MAXRSS];
7617 char *pathified, *vmsified, *cp;
7619 if (path == NULL) return NULL;
7620 pathified = PerlMem_malloc(VMS_MAXRSS);
7621 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7622 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7623 PerlMem_free(pathified);
7629 Newx(vmsified, VMS_MAXRSS, char);
7630 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7631 PerlMem_free(pathified);
7632 if (vmsified) Safefree(vmsified);
7635 PerlMem_free(pathified);
7640 vmslen = strlen(vmsified);
7641 Newx(cp,vmslen+1,char);
7642 memcpy(cp,vmsified,vmslen);
7648 strcpy(__tovmspath_retbuf,vmsified);
7650 return __tovmspath_retbuf;
7653 } /* end of do_tovmspath() */
7655 /* External entry points */
7656 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7657 { return do_tovmspath(path,buf,0, NULL); }
7658 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7659 { return do_tovmspath(path,buf,1, NULL); }
7660 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7661 { return do_tovmspath(path,buf,0,utf8_fl); }
7662 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7663 { return do_tovmspath(path,buf,1,utf8_fl); }
7666 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7667 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7668 static char __tounixpath_retbuf[VMS_MAXRSS];
7670 char *pathified, *unixified, *cp;
7672 if (path == NULL) return NULL;
7673 pathified = PerlMem_malloc(VMS_MAXRSS);
7674 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7675 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7676 PerlMem_free(pathified);
7682 Newx(unixified, VMS_MAXRSS, char);
7684 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7685 PerlMem_free(pathified);
7686 if (unixified) Safefree(unixified);
7689 PerlMem_free(pathified);
7694 unixlen = strlen(unixified);
7695 Newx(cp,unixlen+1,char);
7696 memcpy(cp,unixified,unixlen);
7698 Safefree(unixified);
7702 strcpy(__tounixpath_retbuf,unixified);
7703 Safefree(unixified);
7704 return __tounixpath_retbuf;
7707 } /* end of do_tounixpath() */
7709 /* External entry points */
7710 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7711 { return do_tounixpath(path,buf,0,NULL); }
7712 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7713 { return do_tounixpath(path,buf,1,NULL); }
7714 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7715 { return do_tounixpath(path,buf,0,utf8_fl); }
7716 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7717 { return do_tounixpath(path,buf,1,utf8_fl); }
7720 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
7722 *****************************************************************************
7724 * Copyright (C) 1989-1994 by *
7725 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
7727 * Permission is hereby granted for the reproduction of this software, *
7728 * on condition that this copyright notice is included in the reproduction, *
7729 * and that such reproduction is not for purposes of profit or material *
7732 * 27-Aug-1994 Modified for inclusion in perl5 *
7733 * by Charles Bailey bailey@newman.upenn.edu *
7734 *****************************************************************************
7738 * getredirection() is intended to aid in porting C programs
7739 * to VMS (Vax-11 C). The native VMS environment does not support
7740 * '>' and '<' I/O redirection, or command line wild card expansion,
7741 * or a command line pipe mechanism using the '|' AND background
7742 * command execution '&'. All of these capabilities are provided to any
7743 * C program which calls this procedure as the first thing in the
7745 * The piping mechanism will probably work with almost any 'filter' type
7746 * of program. With suitable modification, it may useful for other
7747 * portability problems as well.
7749 * Author: Mark Pizzolato mark@infocomm.com
7753 struct list_item *next;
7757 static void add_item(struct list_item **head,
7758 struct list_item **tail,
7762 static void mp_expand_wild_cards(pTHX_ char *item,
7763 struct list_item **head,
7764 struct list_item **tail,
7767 static int background_process(pTHX_ int argc, char **argv);
7769 static void pipe_and_fork(pTHX_ char **cmargv);
7771 /*{{{ void getredirection(int *ac, char ***av)*/
7773 mp_getredirection(pTHX_ int *ac, char ***av)
7775 * Process vms redirection arg's. Exit if any error is seen.
7776 * If getredirection() processes an argument, it is erased
7777 * from the vector. getredirection() returns a new argc and argv value.
7778 * In the event that a background command is requested (by a trailing "&"),
7779 * this routine creates a background subprocess, and simply exits the program.
7781 * Warning: do not try to simplify the code for vms. The code
7782 * presupposes that getredirection() is called before any data is
7783 * read from stdin or written to stdout.
7785 * Normal usage is as follows:
7791 * getredirection(&argc, &argv);
7795 int argc = *ac; /* Argument Count */
7796 char **argv = *av; /* Argument Vector */
7797 char *ap; /* Argument pointer */
7798 int j; /* argv[] index */
7799 int item_count = 0; /* Count of Items in List */
7800 struct list_item *list_head = 0; /* First Item in List */
7801 struct list_item *list_tail; /* Last Item in List */
7802 char *in = NULL; /* Input File Name */
7803 char *out = NULL; /* Output File Name */
7804 char *outmode = "w"; /* Mode to Open Output File */
7805 char *err = NULL; /* Error File Name */
7806 char *errmode = "w"; /* Mode to Open Error File */
7807 int cmargc = 0; /* Piped Command Arg Count */
7808 char **cmargv = NULL;/* Piped Command Arg Vector */
7811 * First handle the case where the last thing on the line ends with
7812 * a '&'. This indicates the desire for the command to be run in a
7813 * subprocess, so we satisfy that desire.
7816 if (0 == strcmp("&", ap))
7817 exit(background_process(aTHX_ --argc, argv));
7818 if (*ap && '&' == ap[strlen(ap)-1])
7820 ap[strlen(ap)-1] = '\0';
7821 exit(background_process(aTHX_ argc, argv));
7824 * Now we handle the general redirection cases that involve '>', '>>',
7825 * '<', and pipes '|'.
7827 for (j = 0; j < argc; ++j)
7829 if (0 == strcmp("<", argv[j]))
7833 fprintf(stderr,"No input file after < on command line");
7834 exit(LIB$_WRONUMARG);
7839 if ('<' == *(ap = argv[j]))
7844 if (0 == strcmp(">", ap))
7848 fprintf(stderr,"No output file after > on command line");
7849 exit(LIB$_WRONUMARG);
7868 fprintf(stderr,"No output file after > or >> on command line");
7869 exit(LIB$_WRONUMARG);
7873 if (('2' == *ap) && ('>' == ap[1]))
7890 fprintf(stderr,"No output file after 2> or 2>> on command line");
7891 exit(LIB$_WRONUMARG);
7895 if (0 == strcmp("|", argv[j]))
7899 fprintf(stderr,"No command into which to pipe on command line");
7900 exit(LIB$_WRONUMARG);
7902 cmargc = argc-(j+1);
7903 cmargv = &argv[j+1];
7907 if ('|' == *(ap = argv[j]))
7915 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7918 * Allocate and fill in the new argument vector, Some Unix's terminate
7919 * the list with an extra null pointer.
7921 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7922 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7924 for (j = 0; j < item_count; ++j, list_head = list_head->next)
7925 argv[j] = list_head->value;
7931 fprintf(stderr,"'|' and '>' may not both be specified on command line");
7932 exit(LIB$_INVARGORD);
7934 pipe_and_fork(aTHX_ cmargv);
7937 /* Check for input from a pipe (mailbox) */
7939 if (in == NULL && 1 == isapipe(0))
7941 char mbxname[L_tmpnam];
7943 long int dvi_item = DVI$_DEVBUFSIZ;
7944 $DESCRIPTOR(mbxnam, "");
7945 $DESCRIPTOR(mbxdevnam, "");
7947 /* Input from a pipe, reopen it in binary mode to disable */
7948 /* carriage control processing. */
7950 fgetname(stdin, mbxname);
7951 mbxnam.dsc$a_pointer = mbxname;
7952 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7953 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7954 mbxdevnam.dsc$a_pointer = mbxname;
7955 mbxdevnam.dsc$w_length = sizeof(mbxname);
7956 dvi_item = DVI$_DEVNAM;
7957 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7958 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7961 freopen(mbxname, "rb", stdin);
7964 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7968 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7970 fprintf(stderr,"Can't open input file %s as stdin",in);
7973 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7975 fprintf(stderr,"Can't open output file %s as stdout",out);
7978 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7981 if (strcmp(err,"&1") == 0) {
7982 dup2(fileno(stdout), fileno(stderr));
7983 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7986 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7988 fprintf(stderr,"Can't open error file %s as stderr",err);
7992 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7996 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7999 #ifdef ARGPROC_DEBUG
8000 PerlIO_printf(Perl_debug_log, "Arglist:\n");
8001 for (j = 0; j < *ac; ++j)
8002 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8004 /* Clear errors we may have hit expanding wildcards, so they don't
8005 show up in Perl's $! later */
8006 set_errno(0); set_vaxc_errno(1);
8007 } /* end of getredirection() */
8010 static void add_item(struct list_item **head,
8011 struct list_item **tail,
8017 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8018 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8022 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8023 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8024 *tail = (*tail)->next;
8026 (*tail)->value = value;
8030 static void mp_expand_wild_cards(pTHX_ char *item,
8031 struct list_item **head,
8032 struct list_item **tail,
8036 unsigned long int context = 0;
8044 $DESCRIPTOR(filespec, "");
8045 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8046 $DESCRIPTOR(resultspec, "");
8047 unsigned long int lff_flags = 0;
8051 #ifdef VMS_LONGNAME_SUPPORT
8052 lff_flags = LIB$M_FIL_LONG_NAMES;
8055 for (cp = item; *cp; cp++) {
8056 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8057 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8059 if (!*cp || isspace(*cp))
8061 add_item(head, tail, item, count);
8066 /* "double quoted" wild card expressions pass as is */
8067 /* From DCL that means using e.g.: */
8068 /* perl program """perl.*""" */
8069 item_len = strlen(item);
8070 if ( '"' == *item && '"' == item[item_len-1] )
8073 item[item_len-2] = '\0';
8074 add_item(head, tail, item, count);
8078 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8079 resultspec.dsc$b_class = DSC$K_CLASS_D;
8080 resultspec.dsc$a_pointer = NULL;
8081 vmsspec = PerlMem_malloc(VMS_MAXRSS);
8082 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8083 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8084 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8085 if (!isunix || !filespec.dsc$a_pointer)
8086 filespec.dsc$a_pointer = item;
8087 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8089 * Only return version specs, if the caller specified a version
8091 had_version = strchr(item, ';');
8093 * Only return device and directory specs, if the caller specifed either.
8095 had_device = strchr(item, ':');
8096 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8098 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8099 (&filespec, &resultspec, &context,
8100 &defaultspec, 0, &rms_sts, &lff_flags)))
8105 string = PerlMem_malloc(resultspec.dsc$w_length+1);
8106 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8107 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8108 string[resultspec.dsc$w_length] = '\0';
8109 if (NULL == had_version)
8110 *(strrchr(string, ';')) = '\0';
8111 if ((!had_directory) && (had_device == NULL))
8113 if (NULL == (devdir = strrchr(string, ']')))
8114 devdir = strrchr(string, '>');
8115 strcpy(string, devdir + 1);
8118 * Be consistent with what the C RTL has already done to the rest of
8119 * the argv items and lowercase all of these names.
8121 if (!decc_efs_case_preserve) {
8122 for (c = string; *c; ++c)
8126 if (isunix) trim_unixpath(string,item,1);
8127 add_item(head, tail, string, count);
8130 PerlMem_free(vmsspec);
8131 if (sts != RMS$_NMF)
8133 set_vaxc_errno(sts);
8136 case RMS$_FNF: case RMS$_DNF:
8137 set_errno(ENOENT); break;
8139 set_errno(ENOTDIR); break;
8141 set_errno(ENODEV); break;
8142 case RMS$_FNM: case RMS$_SYN:
8143 set_errno(EINVAL); break;
8145 set_errno(EACCES); break;
8147 _ckvmssts_noperl(sts);
8151 add_item(head, tail, item, count);
8152 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8153 _ckvmssts_noperl(lib$find_file_end(&context));
8156 static int child_st[2];/* Event Flag set when child process completes */
8158 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
8160 static unsigned long int exit_handler(int *status)
8164 if (0 == child_st[0])
8166 #ifdef ARGPROC_DEBUG
8167 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8169 fflush(stdout); /* Have to flush pipe for binary data to */
8170 /* terminate properly -- <tp@mccall.com> */
8171 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8172 sys$dassgn(child_chan);
8174 sys$synch(0, child_st);
8179 static void sig_child(int chan)
8181 #ifdef ARGPROC_DEBUG
8182 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8184 if (child_st[0] == 0)
8188 static struct exit_control_block exit_block =
8193 &exit_block.exit_status,
8198 pipe_and_fork(pTHX_ char **cmargv)
8201 struct dsc$descriptor_s *vmscmd;
8202 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8203 int sts, j, l, ismcr, quote, tquote = 0;
8205 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
8206 vms_execfree(vmscmd);
8211 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
8212 && toupper(*(q+2)) == 'R' && !*(q+3);
8214 while (q && l < MAX_DCL_LINE_LENGTH) {
8216 if (j > 0 && quote) {
8222 if (ismcr && j > 1) quote = 1;
8223 tquote = (strchr(q,' ')) != NULL || *q == '\0';
8226 if (quote || tquote) {
8232 if ((quote||tquote) && *q == '"') {
8242 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8244 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8248 static int background_process(pTHX_ int argc, char **argv)
8250 char command[MAX_DCL_SYMBOL + 1] = "$";
8251 $DESCRIPTOR(value, "");
8252 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8253 static $DESCRIPTOR(null, "NLA0:");
8254 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8256 $DESCRIPTOR(pidstr, "");
8258 unsigned long int flags = 17, one = 1, retsts;
8261 strcat(command, argv[0]);
8262 len = strlen(command);
8263 while (--argc && (len < MAX_DCL_SYMBOL))
8265 strcat(command, " \"");
8266 strcat(command, *(++argv));
8267 strcat(command, "\"");
8268 len = strlen(command);
8270 value.dsc$a_pointer = command;
8271 value.dsc$w_length = strlen(value.dsc$a_pointer);
8272 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8273 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8274 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8275 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8278 _ckvmssts_noperl(retsts);
8280 #ifdef ARGPROC_DEBUG
8281 PerlIO_printf(Perl_debug_log, "%s\n", command);
8283 sprintf(pidstring, "%08X", pid);
8284 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8285 pidstr.dsc$a_pointer = pidstring;
8286 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8287 lib$set_symbol(&pidsymbol, &pidstr);
8291 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8294 /* OS-specific initialization at image activation (not thread startup) */
8295 /* Older VAXC header files lack these constants */
8296 #ifndef JPI$_RIGHTS_SIZE
8297 # define JPI$_RIGHTS_SIZE 817
8299 #ifndef KGB$M_SUBSYSTEM
8300 # define KGB$M_SUBSYSTEM 0x8
8303 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8305 /*{{{void vms_image_init(int *, char ***)*/
8307 vms_image_init(int *argcp, char ***argvp)
8309 char eqv[LNM$C_NAMLENGTH+1] = "";
8310 unsigned int len, tabct = 8, tabidx = 0;
8311 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8312 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8313 unsigned short int dummy, rlen;
8314 struct dsc$descriptor_s **tabvec;
8315 #if defined(PERL_IMPLICIT_CONTEXT)
8318 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8319 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8320 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8323 #ifdef KILL_BY_SIGPRC
8324 Perl_csighandler_init();
8327 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8328 _ckvmssts_noperl(iosb[0]);
8329 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8330 if (iprv[i]) { /* Running image installed with privs? */
8331 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
8336 /* Rights identifiers might trigger tainting as well. */
8337 if (!will_taint && (rlen || rsz)) {
8338 while (rlen < rsz) {
8339 /* We didn't get all the identifiers on the first pass. Allocate a
8340 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8341 * were needed to hold all identifiers at time of last call; we'll
8342 * allocate that many unsigned long ints), and go back and get 'em.
8343 * If it gave us less than it wanted to despite ample buffer space,
8344 * something's broken. Is your system missing a system identifier?
8346 if (rsz <= jpilist[1].buflen) {
8347 /* Perl_croak accvios when used this early in startup. */
8348 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8349 rsz, (unsigned long) jpilist[1].buflen,
8350 "Check your rights database for corruption.\n");
8353 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8354 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8355 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8356 jpilist[1].buflen = rsz * sizeof(unsigned long int);
8357 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8358 _ckvmssts_noperl(iosb[0]);
8360 mask = jpilist[1].bufadr;
8361 /* Check attribute flags for each identifier (2nd longword); protected
8362 * subsystem identifiers trigger tainting.
8364 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8365 if (mask[i] & KGB$M_SUBSYSTEM) {
8370 if (mask != rlst) PerlMem_free(mask);
8373 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8374 * logical, some versions of the CRTL will add a phanthom /000000/
8375 * directory. This needs to be removed.
8377 if (decc_filename_unix_report) {
8380 ulen = strlen(argvp[0][0]);
8382 zeros = strstr(argvp[0][0], "/000000/");
8383 if (zeros != NULL) {
8385 mlen = ulen - (zeros - argvp[0][0]) - 7;
8386 memmove(zeros, &zeros[7], mlen);
8388 argvp[0][0][ulen] = '\0';
8391 /* It also may have a trailing dot that needs to be removed otherwise
8392 * it will be converted to VMS mode incorrectly.
8395 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8396 argvp[0][0][ulen] = '\0';
8399 /* We need to use this hack to tell Perl it should run with tainting,
8400 * since its tainting flag may be part of the PL_curinterp struct, which
8401 * hasn't been allocated when vms_image_init() is called.
8404 char **newargv, **oldargv;
8406 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8407 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8408 newargv[0] = oldargv[0];
8409 newargv[1] = PerlMem_malloc(3 * sizeof(char));
8410 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8411 strcpy(newargv[1], "-T");
8412 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8414 newargv[*argcp] = NULL;
8415 /* We orphan the old argv, since we don't know where it's come from,
8416 * so we don't know how to free it.
8420 else { /* Did user explicitly request tainting? */
8422 char *cp, **av = *argvp;
8423 for (i = 1; i < *argcp; i++) {
8424 if (*av[i] != '-') break;
8425 for (cp = av[i]+1; *cp; cp++) {
8426 if (*cp == 'T') { will_taint = 1; break; }
8427 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8428 strchr("DFIiMmx",*cp)) break;
8430 if (will_taint) break;
8435 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8438 tabvec = (struct dsc$descriptor_s **)
8439 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8440 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8442 else if (tabidx >= tabct) {
8444 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8445 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8447 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8448 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8449 tabvec[tabidx]->dsc$w_length = 0;
8450 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
8451 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
8452 tabvec[tabidx]->dsc$a_pointer = NULL;
8453 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8455 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8457 getredirection(argcp,argvp);
8458 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8460 # include <reentrancy.h>
8461 decc$set_reentrancy(C$C_MULTITHREAD);
8470 * Trim Unix-style prefix off filespec, so it looks like what a shell
8471 * glob expansion would return (i.e. from specified prefix on, not
8472 * full path). Note that returned filespec is Unix-style, regardless
8473 * of whether input filespec was VMS-style or Unix-style.
8475 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8476 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
8477 * vector of options; at present, only bit 0 is used, and if set tells
8478 * trim unixpath to try the current default directory as a prefix when
8479 * presented with a possibly ambiguous ... wildcard.
8481 * Returns !=0 on success, with trimmed filespec replacing contents of
8482 * fspec, and 0 on failure, with contents of fpsec unchanged.
8484 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8486 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8488 char *unixified, *unixwild,
8489 *template, *base, *end, *cp1, *cp2;
8490 register int tmplen, reslen = 0, dirs = 0;
8492 unixwild = PerlMem_malloc(VMS_MAXRSS);
8493 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8494 if (!wildspec || !fspec) return 0;
8495 template = unixwild;
8496 if (strpbrk(wildspec,"]>:") != NULL) {
8497 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8498 PerlMem_free(unixwild);
8503 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8504 unixwild[VMS_MAXRSS-1] = 0;
8506 unixified = PerlMem_malloc(VMS_MAXRSS);
8507 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8508 if (strpbrk(fspec,"]>:") != NULL) {
8509 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8510 PerlMem_free(unixwild);
8511 PerlMem_free(unixified);
8514 else base = unixified;
8515 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8516 * check to see that final result fits into (isn't longer than) fspec */
8517 reslen = strlen(fspec);
8521 /* No prefix or absolute path on wildcard, so nothing to remove */
8522 if (!*template || *template == '/') {
8523 PerlMem_free(unixwild);
8524 if (base == fspec) {
8525 PerlMem_free(unixified);
8528 tmplen = strlen(unixified);
8529 if (tmplen > reslen) {
8530 PerlMem_free(unixified);
8531 return 0; /* not enough space */
8533 /* Copy unixified resultant, including trailing NUL */
8534 memmove(fspec,unixified,tmplen+1);
8535 PerlMem_free(unixified);
8539 for (end = base; *end; end++) ; /* Find end of resultant filespec */
8540 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8541 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8542 for (cp1 = end ;cp1 >= base; cp1--)
8543 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8545 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8546 PerlMem_free(unixified);
8547 PerlMem_free(unixwild);
8552 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8553 int ells = 1, totells, segdirs, match;
8554 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8555 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8557 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8559 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8560 tpl = PerlMem_malloc(VMS_MAXRSS);
8561 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8562 if (ellipsis == template && opts & 1) {
8563 /* Template begins with an ellipsis. Since we can't tell how many
8564 * directory names at the front of the resultant to keep for an
8565 * arbitrary starting point, we arbitrarily choose the current
8566 * default directory as a starting point. If it's there as a prefix,
8567 * clip it off. If not, fall through and act as if the leading
8568 * ellipsis weren't there (i.e. return shortest possible path that
8569 * could match template).
8571 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8573 PerlMem_free(unixified);
8574 PerlMem_free(unixwild);
8577 if (!decc_efs_case_preserve) {
8578 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8579 if (_tolower(*cp1) != _tolower(*cp2)) break;
8581 segdirs = dirs - totells; /* Min # of dirs we must have left */
8582 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8583 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8584 memmove(fspec,cp2+1,end - cp2);
8586 PerlMem_free(unixified);
8587 PerlMem_free(unixwild);
8591 /* First off, back up over constant elements at end of path */
8593 for (front = end ; front >= base; front--)
8594 if (*front == '/' && !dirs--) { front++; break; }
8596 lcres = PerlMem_malloc(VMS_MAXRSS);
8597 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8598 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8600 if (!decc_efs_case_preserve) {
8601 *cp2 = _tolower(*cp1); /* Make lc copy for match */
8609 PerlMem_free(unixified);
8610 PerlMem_free(unixwild);
8611 PerlMem_free(lcres);
8612 return 0; /* Path too long. */
8615 *cp2 = '\0'; /* Pick up with memcpy later */
8616 lcfront = lcres + (front - base);
8617 /* Now skip over each ellipsis and try to match the path in front of it. */
8619 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8620 if (*(cp1) == '.' && *(cp1+1) == '.' &&
8621 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
8622 if (cp1 < template) break; /* template started with an ellipsis */
8623 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8624 ellipsis = cp1; continue;
8626 wilddsc.dsc$a_pointer = tpl;
8627 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8629 for (segdirs = 0, cp2 = tpl;
8630 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8632 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8634 if (!decc_efs_case_preserve) {
8635 *cp2 = _tolower(*cp1); /* else lowercase for match */
8638 *cp2 = *cp1; /* else preserve case for match */
8641 if (*cp2 == '/') segdirs++;
8643 if (cp1 != ellipsis - 1) {
8645 PerlMem_free(unixified);
8646 PerlMem_free(unixwild);
8647 PerlMem_free(lcres);
8648 return 0; /* Path too long */
8650 /* Back up at least as many dirs as in template before matching */
8651 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8652 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8653 for (match = 0; cp1 > lcres;) {
8654 resdsc.dsc$a_pointer = cp1;
8655 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8657 if (match == 1) lcfront = cp1;
8659 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8663 PerlMem_free(unixified);
8664 PerlMem_free(unixwild);
8665 PerlMem_free(lcres);
8666 return 0; /* Can't find prefix ??? */
8668 if (match > 1 && opts & 1) {
8669 /* This ... wildcard could cover more than one set of dirs (i.e.
8670 * a set of similar dir names is repeated). If the template
8671 * contains more than 1 ..., upstream elements could resolve the
8672 * ambiguity, but it's not worth a full backtracking setup here.
8673 * As a quick heuristic, clip off the current default directory
8674 * if it's present to find the trimmed spec, else use the
8675 * shortest string that this ... could cover.
8677 char def[NAM$C_MAXRSS+1], *st;
8679 if (getcwd(def, sizeof def,0) == NULL) {
8680 Safefree(unixified);
8686 if (!decc_efs_case_preserve) {
8687 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8688 if (_tolower(*cp1) != _tolower(*cp2)) break;
8690 segdirs = dirs - totells; /* Min # of dirs we must have left */
8691 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8692 if (*cp1 == '\0' && *cp2 == '/') {
8693 memmove(fspec,cp2+1,end - cp2);
8695 PerlMem_free(unixified);
8696 PerlMem_free(unixwild);
8697 PerlMem_free(lcres);
8700 /* Nope -- stick with lcfront from above and keep going. */
8703 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8705 PerlMem_free(unixified);
8706 PerlMem_free(unixwild);
8707 PerlMem_free(lcres);
8712 } /* end of trim_unixpath() */
8717 * VMS readdir() routines.
8718 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8720 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
8721 * Minor modifications to original routines.
8724 /* readdir may have been redefined by reentr.h, so make sure we get
8725 * the local version for what we do here.
8730 #if !defined(PERL_IMPLICIT_CONTEXT)
8731 # define readdir Perl_readdir
8733 # define readdir(a) Perl_readdir(aTHX_ a)
8736 /* Number of elements in vms_versions array */
8737 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
8740 * Open a directory, return a handle for later use.
8742 /*{{{ DIR *opendir(char*name) */
8744 Perl_opendir(pTHX_ const char *name)
8752 if (decc_efs_charset) {
8753 unix_flag = is_unix_filespec(name);
8756 Newx(dir, VMS_MAXRSS, char);
8757 if (do_tovmspath(name,dir,0,NULL) == NULL) {
8761 /* Check access before stat; otherwise stat does not
8762 * accurately report whether it's a directory.
8764 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8765 /* cando_by_name has already set errno */
8769 if (flex_stat(dir,&sb) == -1) return NULL;
8770 if (!S_ISDIR(sb.st_mode)) {
8772 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
8775 /* Get memory for the handle, and the pattern. */
8777 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8779 /* Fill in the fields; mainly playing with the descriptor. */
8780 sprintf(dd->pattern, "%s*.*",dir);
8786 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8787 dd->pat.dsc$a_pointer = dd->pattern;
8788 dd->pat.dsc$w_length = strlen(dd->pattern);
8789 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8790 dd->pat.dsc$b_class = DSC$K_CLASS_S;
8791 #if defined(USE_ITHREADS)
8792 Newx(dd->mutex,1,perl_mutex);
8793 MUTEX_INIT( (perl_mutex *) dd->mutex );
8799 } /* end of opendir() */
8803 * Set the flag to indicate we want versions or not.
8805 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8807 vmsreaddirversions(DIR *dd, int flag)
8810 dd->flags |= PERL_VMSDIR_M_VERSIONS;
8812 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8817 * Free up an opened directory.
8819 /*{{{ void closedir(DIR *dd)*/
8821 Perl_closedir(DIR *dd)
8825 sts = lib$find_file_end(&dd->context);
8826 Safefree(dd->pattern);
8827 #if defined(USE_ITHREADS)
8828 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8829 Safefree(dd->mutex);
8836 * Collect all the version numbers for the current file.
8839 collectversions(pTHX_ DIR *dd)
8841 struct dsc$descriptor_s pat;
8842 struct dsc$descriptor_s res;
8844 char *p, *text, *buff;
8846 unsigned long context, tmpsts;
8848 /* Convenient shorthand. */
8851 /* Add the version wildcard, ignoring the "*.*" put on before */
8852 i = strlen(dd->pattern);
8853 Newx(text,i + e->d_namlen + 3,char);
8854 strcpy(text, dd->pattern);
8855 sprintf(&text[i - 3], "%s;*", e->d_name);
8857 /* Set up the pattern descriptor. */
8858 pat.dsc$a_pointer = text;
8859 pat.dsc$w_length = i + e->d_namlen - 1;
8860 pat.dsc$b_dtype = DSC$K_DTYPE_T;
8861 pat.dsc$b_class = DSC$K_CLASS_S;
8863 /* Set up result descriptor. */
8864 Newx(buff, VMS_MAXRSS, char);
8865 res.dsc$a_pointer = buff;
8866 res.dsc$w_length = VMS_MAXRSS - 1;
8867 res.dsc$b_dtype = DSC$K_DTYPE_T;
8868 res.dsc$b_class = DSC$K_CLASS_S;
8870 /* Read files, collecting versions. */
8871 for (context = 0, e->vms_verscount = 0;
8872 e->vms_verscount < VERSIZE(e);
8873 e->vms_verscount++) {
8875 unsigned long flags = 0;
8877 #ifdef VMS_LONGNAME_SUPPORT
8878 flags = LIB$M_FIL_LONG_NAMES;
8880 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8881 if (tmpsts == RMS$_NMF || context == 0) break;
8883 buff[VMS_MAXRSS - 1] = '\0';
8884 if ((p = strchr(buff, ';')))
8885 e->vms_versions[e->vms_verscount] = atoi(p + 1);
8887 e->vms_versions[e->vms_verscount] = -1;
8890 _ckvmssts(lib$find_file_end(&context));
8894 } /* end of collectversions() */
8897 * Read the next entry from the directory.
8899 /*{{{ struct dirent *readdir(DIR *dd)*/
8901 Perl_readdir(pTHX_ DIR *dd)
8903 struct dsc$descriptor_s res;
8905 unsigned long int tmpsts;
8907 unsigned long flags = 0;
8908 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8909 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8911 /* Set up result descriptor, and get next file. */
8912 Newx(buff, VMS_MAXRSS, char);
8913 res.dsc$a_pointer = buff;
8914 res.dsc$w_length = VMS_MAXRSS - 1;
8915 res.dsc$b_dtype = DSC$K_DTYPE_T;
8916 res.dsc$b_class = DSC$K_CLASS_S;
8918 #ifdef VMS_LONGNAME_SUPPORT
8919 flags = LIB$M_FIL_LONG_NAMES;
8922 tmpsts = lib$find_file
8923 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8924 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
8925 if (!(tmpsts & 1)) {
8926 set_vaxc_errno(tmpsts);
8929 set_errno(EACCES); break;
8931 set_errno(ENODEV); break;
8933 set_errno(ENOTDIR); break;
8934 case RMS$_FNF: case RMS$_DNF:
8935 set_errno(ENOENT); break;
8943 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8944 if (!decc_efs_case_preserve) {
8945 buff[VMS_MAXRSS - 1] = '\0';
8946 for (p = buff; *p; p++) *p = _tolower(*p);
8949 /* we don't want to force to lowercase, just null terminate */
8950 buff[res.dsc$w_length] = '\0';
8952 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
8955 /* Skip any directory component and just copy the name. */
8956 sts = vms_split_path
8971 /* Drop NULL extensions on UNIX file specification */
8972 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8973 (e_len == 1) && decc_readdir_dropdotnotype)) {
8978 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8979 dd->entry.d_name[n_len + e_len] = '\0';
8980 dd->entry.d_namlen = strlen(dd->entry.d_name);
8982 /* Convert the filename to UNIX format if needed */
8983 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8985 /* Translate the encoded characters. */
8986 /* Fixme: unicode handling could result in embedded 0 characters */
8987 if (strchr(dd->entry.d_name, '^') != NULL) {
8991 p = dd->entry.d_name;
8995 x = copy_expand_vms_filename_escape(q, p, &y);
8999 /* if y > 1, then this is a wide file specification */
9000 /* Wide file specifications need to be passed in Perl */
9001 /* counted strings apparently with a unicode flag */
9004 strcpy(dd->entry.d_name, new_name);
9008 dd->entry.vms_verscount = 0;
9009 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9013 } /* end of readdir() */
9017 * Read the next entry from the directory -- thread-safe version.
9019 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9021 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9025 MUTEX_LOCK( (perl_mutex *) dd->mutex );
9027 entry = readdir(dd);
9029 retval = ( *result == NULL ? errno : 0 );
9031 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9035 } /* end of readdir_r() */
9039 * Return something that can be used in a seekdir later.
9041 /*{{{ long telldir(DIR *dd)*/
9043 Perl_telldir(DIR *dd)
9050 * Return to a spot where we used to be. Brute force.
9052 /*{{{ void seekdir(DIR *dd,long count)*/
9054 Perl_seekdir(pTHX_ DIR *dd, long count)
9058 /* If we haven't done anything yet... */
9062 /* Remember some state, and clear it. */
9063 old_flags = dd->flags;
9064 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9065 _ckvmssts(lib$find_file_end(&dd->context));
9068 /* The increment is in readdir(). */
9069 for (dd->count = 0; dd->count < count; )
9072 dd->flags = old_flags;
9074 } /* end of seekdir() */
9077 /* VMS subprocess management
9079 * my_vfork() - just a vfork(), after setting a flag to record that
9080 * the current script is trying a Unix-style fork/exec.
9082 * vms_do_aexec() and vms_do_exec() are called in response to the
9083 * perl 'exec' function. If this follows a vfork call, then they
9084 * call out the regular perl routines in doio.c which do an
9085 * execvp (for those who really want to try this under VMS).
9086 * Otherwise, they do exactly what the perl docs say exec should
9087 * do - terminate the current script and invoke a new command
9088 * (See below for notes on command syntax.)
9090 * do_aspawn() and do_spawn() implement the VMS side of the perl
9091 * 'system' function.
9093 * Note on command arguments to perl 'exec' and 'system': When handled
9094 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9095 * are concatenated to form a DCL command string. If the first arg
9096 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9097 * the command string is handed off to DCL directly. Otherwise,
9098 * the first token of the command is taken as the filespec of an image
9099 * to run. The filespec is expanded using a default type of '.EXE' and
9100 * the process defaults for device, directory, etc., and if found, the resultant
9101 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9102 * the command string as parameters. This is perhaps a bit complicated,
9103 * but I hope it will form a happy medium between what VMS folks expect
9104 * from lib$spawn and what Unix folks expect from exec.
9107 static int vfork_called;
9109 /*{{{int my_vfork()*/
9120 vms_execfree(struct dsc$descriptor_s *vmscmd)
9123 if (vmscmd->dsc$a_pointer) {
9124 PerlMem_free(vmscmd->dsc$a_pointer);
9126 PerlMem_free(vmscmd);
9131 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9133 char *junk, *tmps = Nullch;
9134 register size_t cmdlen = 0;
9141 tmps = SvPV(really,rlen);
9148 for (idx++; idx <= sp; idx++) {
9150 junk = SvPVx(*idx,rlen);
9151 cmdlen += rlen ? rlen + 1 : 0;
9154 Newx(PL_Cmd, cmdlen+1, char);
9156 if (tmps && *tmps) {
9157 strcpy(PL_Cmd,tmps);
9160 else *PL_Cmd = '\0';
9161 while (++mark <= sp) {
9163 char *s = SvPVx(*mark,n_a);
9165 if (*PL_Cmd) strcat(PL_Cmd," ");
9171 } /* end of setup_argstr() */
9174 static unsigned long int
9175 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9176 struct dsc$descriptor_s **pvmscmd)
9178 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9179 char image_name[NAM$C_MAXRSS+1];
9180 char image_argv[NAM$C_MAXRSS+1];
9181 $DESCRIPTOR(defdsc,".EXE");
9182 $DESCRIPTOR(defdsc2,".");
9183 $DESCRIPTOR(resdsc,resspec);
9184 struct dsc$descriptor_s *vmscmd;
9185 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9186 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9187 register char *s, *rest, *cp, *wordbreak;
9192 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9193 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9195 /* Make a copy for modification */
9196 cmdlen = strlen(incmd);
9197 cmd = PerlMem_malloc(cmdlen+1);
9198 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9199 strncpy(cmd, incmd, cmdlen);
9204 vmscmd->dsc$a_pointer = NULL;
9205 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
9206 vmscmd->dsc$b_class = DSC$K_CLASS_S;
9207 vmscmd->dsc$w_length = 0;
9208 if (pvmscmd) *pvmscmd = vmscmd;
9210 if (suggest_quote) *suggest_quote = 0;
9212 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9214 return CLI$_BUFOVF; /* continuation lines currently unsupported */
9219 while (*s && isspace(*s)) s++;
9221 if (*s == '@' || *s == '$') {
9222 vmsspec[0] = *s; rest = s + 1;
9223 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9225 else { cp = vmsspec; rest = s; }
9226 if (*rest == '.' || *rest == '/') {
9229 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9230 rest++, cp2++) *cp2 = *rest;
9232 if (do_tovmsspec(resspec,cp,0,NULL)) {
9235 for (cp2 = vmsspec + strlen(vmsspec);
9236 *rest && cp2 - vmsspec < sizeof vmsspec;
9237 rest++, cp2++) *cp2 = *rest;
9242 /* Intuit whether verb (first word of cmd) is a DCL command:
9243 * - if first nonspace char is '@', it's a DCL indirection
9245 * - if verb contains a filespec separator, it's not a DCL command
9246 * - if it doesn't, caller tells us whether to default to a DCL
9247 * command, or to a local image unless told it's DCL (by leading '$')
9251 if (suggest_quote) *suggest_quote = 1;
9253 register char *filespec = strpbrk(s,":<[.;");
9254 rest = wordbreak = strpbrk(s," \"\t/");
9255 if (!wordbreak) wordbreak = s + strlen(s);
9256 if (*s == '$') check_img = 0;
9257 if (filespec && (filespec < wordbreak)) isdcl = 0;
9258 else isdcl = !check_img;
9263 imgdsc.dsc$a_pointer = s;
9264 imgdsc.dsc$w_length = wordbreak - s;
9265 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9267 _ckvmssts(lib$find_file_end(&cxt));
9268 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9269 if (!(retsts & 1) && *s == '$') {
9270 _ckvmssts(lib$find_file_end(&cxt));
9271 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9272 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9274 _ckvmssts(lib$find_file_end(&cxt));
9275 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9279 _ckvmssts(lib$find_file_end(&cxt));
9284 while (*s && !isspace(*s)) s++;
9287 /* check that it's really not DCL with no file extension */
9288 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9290 char b[256] = {0,0,0,0};
9291 read(fileno(fp), b, 256);
9292 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9296 /* Check for script */
9298 if ((b[0] == '#') && (b[1] == '!'))
9300 #ifdef ALTERNATE_SHEBANG
9302 shebang_len = strlen(ALTERNATE_SHEBANG);
9303 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9305 perlstr = strstr("perl",b);
9306 if (perlstr == NULL)
9314 if (shebang_len > 0) {
9317 char tmpspec[NAM$C_MAXRSS + 1];
9320 /* Image is following after white space */
9321 /*--------------------------------------*/
9322 while (isprint(b[i]) && isspace(b[i]))
9326 while (isprint(b[i]) && !isspace(b[i])) {
9327 tmpspec[j++] = b[i++];
9328 if (j >= NAM$C_MAXRSS)
9333 /* There may be some default parameters to the image */
9334 /*---------------------------------------------------*/
9336 while (isprint(b[i])) {
9337 image_argv[j++] = b[i++];
9338 if (j >= NAM$C_MAXRSS)
9341 while ((j > 0) && !isprint(image_argv[j-1]))
9345 /* It will need to be converted to VMS format and validated */
9346 if (tmpspec[0] != '\0') {
9349 /* Try to find the exact program requested to be run */
9350 /*---------------------------------------------------*/
9351 iname = do_rmsexpand
9352 (tmpspec, image_name, 0, ".exe",
9353 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9354 if (iname != NULL) {
9355 if (cando_by_name_int
9356 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9357 /* MCR prefix needed */
9361 /* Try again with a null type */
9362 /*----------------------------*/
9363 iname = do_rmsexpand
9364 (tmpspec, image_name, 0, ".",
9365 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9366 if (iname != NULL) {
9367 if (cando_by_name_int
9368 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9369 /* MCR prefix needed */
9375 /* Did we find the image to run the script? */
9376 /*------------------------------------------*/
9380 /* Assume DCL or foreign command exists */
9381 /*--------------------------------------*/
9382 tchr = strrchr(tmpspec, '/');
9389 strcpy(image_name, tchr);
9397 if (check_img && isdcl) return RMS$_FNF;
9399 if (cando_by_name(S_IXUSR,0,resspec)) {
9400 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9401 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9403 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9404 if (image_name[0] != 0) {
9405 strcat(vmscmd->dsc$a_pointer, image_name);
9406 strcat(vmscmd->dsc$a_pointer, " ");
9408 } else if (image_name[0] != 0) {
9409 strcpy(vmscmd->dsc$a_pointer, image_name);
9410 strcat(vmscmd->dsc$a_pointer, " ");
9412 strcpy(vmscmd->dsc$a_pointer,"@");
9414 if (suggest_quote) *suggest_quote = 1;
9416 /* If there is an image name, use original command */
9417 if (image_name[0] == 0)
9418 strcat(vmscmd->dsc$a_pointer,resspec);
9421 while (*rest && isspace(*rest)) rest++;
9424 if (image_argv[0] != 0) {
9425 strcat(vmscmd->dsc$a_pointer,image_argv);
9426 strcat(vmscmd->dsc$a_pointer, " ");
9432 rest_len = strlen(rest);
9433 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9434 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9435 strcat(vmscmd->dsc$a_pointer,rest);
9437 retsts = CLI$_BUFOVF;
9439 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9441 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9447 /* It's either a DCL command or we couldn't find a suitable image */
9448 vmscmd->dsc$w_length = strlen(cmd);
9450 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9451 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9452 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9456 /* check if it's a symbol (for quoting purposes) */
9457 if (suggest_quote && !*suggest_quote) {
9459 char equiv[LNM$C_NAMLENGTH];
9460 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9461 eqvdsc.dsc$a_pointer = equiv;
9463 iss = lib$get_symbol(vmscmd,&eqvdsc);
9464 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9466 if (!(retsts & 1)) {
9467 /* just hand off status values likely to be due to user error */
9468 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9469 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9470 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9471 else { _ckvmssts(retsts); }
9474 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9476 } /* end of setup_cmddsc() */
9479 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9481 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9487 if (vfork_called) { /* this follows a vfork - act Unixish */
9489 if (vfork_called < 0) {
9490 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9493 else return do_aexec(really,mark,sp);
9495 /* no vfork - act VMSish */
9496 cmd = setup_argstr(aTHX_ really,mark,sp);
9497 exec_sts = vms_do_exec(cmd);
9498 Safefree(cmd); /* Clean up from setup_argstr() */
9503 } /* end of vms_do_aexec() */
9506 /* {{{bool vms_do_exec(char *cmd) */
9508 Perl_vms_do_exec(pTHX_ const char *cmd)
9510 struct dsc$descriptor_s *vmscmd;
9512 if (vfork_called) { /* this follows a vfork - act Unixish */
9514 if (vfork_called < 0) {
9515 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9518 else return do_exec(cmd);
9521 { /* no vfork - act VMSish */
9522 unsigned long int retsts;
9525 TAINT_PROPER("exec");
9526 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9527 retsts = lib$do_command(vmscmd);
9530 case RMS$_FNF: case RMS$_DNF:
9531 set_errno(ENOENT); break;
9533 set_errno(ENOTDIR); break;
9535 set_errno(ENODEV); break;
9537 set_errno(EACCES); break;
9539 set_errno(EINVAL); break;
9540 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9541 set_errno(E2BIG); break;
9542 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9543 _ckvmssts(retsts); /* fall through */
9544 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9547 set_vaxc_errno(retsts);
9548 if (ckWARN(WARN_EXEC)) {
9549 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9550 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9552 vms_execfree(vmscmd);
9557 } /* end of vms_do_exec() */
9560 unsigned long int Perl_do_spawn(pTHX_ const char *);
9562 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9564 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9566 unsigned long int sts;
9570 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9571 sts = do_spawn(cmd);
9572 /* pp_sys will clean up cmd */
9576 } /* end of do_aspawn() */
9579 /* {{{unsigned long int do_spawn(char *cmd) */
9581 Perl_do_spawn(pTHX_ const char *cmd)
9583 unsigned long int sts, substs;
9585 /* The caller of this routine expects to Safefree(PL_Cmd) */
9586 Newx(PL_Cmd,10,char);
9589 TAINT_PROPER("spawn");
9590 if (!cmd || !*cmd) {
9591 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9594 case RMS$_FNF: case RMS$_DNF:
9595 set_errno(ENOENT); break;
9597 set_errno(ENOTDIR); break;
9599 set_errno(ENODEV); break;
9601 set_errno(EACCES); break;
9603 set_errno(EINVAL); break;
9604 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9605 set_errno(E2BIG); break;
9606 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9607 _ckvmssts(sts); /* fall through */
9608 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9611 set_vaxc_errno(sts);
9612 if (ckWARN(WARN_EXEC)) {
9613 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9621 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9626 } /* end of do_spawn() */
9630 static unsigned int *sockflags, sockflagsize;
9633 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9634 * routines found in some versions of the CRTL can't deal with sockets.
9635 * We don't shim the other file open routines since a socket isn't
9636 * likely to be opened by a name.
9638 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9639 FILE *my_fdopen(int fd, const char *mode)
9641 FILE *fp = fdopen(fd, mode);
9644 unsigned int fdoff = fd / sizeof(unsigned int);
9645 Stat_t sbuf; /* native stat; we don't need flex_stat */
9646 if (!sockflagsize || fdoff > sockflagsize) {
9647 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
9648 else Newx (sockflags,fdoff+2,unsigned int);
9649 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9650 sockflagsize = fdoff + 2;
9652 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9653 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9662 * Clear the corresponding bit when the (possibly) socket stream is closed.
9663 * There still a small hole: we miss an implicit close which might occur
9664 * via freopen(). >> Todo
9666 /*{{{ int my_fclose(FILE *fp)*/
9667 int my_fclose(FILE *fp) {
9669 unsigned int fd = fileno(fp);
9670 unsigned int fdoff = fd / sizeof(unsigned int);
9672 if (sockflagsize && fdoff <= sockflagsize)
9673 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9681 * A simple fwrite replacement which outputs itmsz*nitm chars without
9682 * introducing record boundaries every itmsz chars.
9683 * We are using fputs, which depends on a terminating null. We may
9684 * well be writing binary data, so we need to accommodate not only
9685 * data with nulls sprinkled in the middle but also data with no null
9688 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9690 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9692 register char *cp, *end, *cpd, *data;
9693 register unsigned int fd = fileno(dest);
9694 register unsigned int fdoff = fd / sizeof(unsigned int);
9696 int bufsize = itmsz * nitm + 1;
9698 if (fdoff < sockflagsize &&
9699 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9700 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9704 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9705 memcpy( data, src, itmsz*nitm );
9706 data[itmsz*nitm] = '\0';
9708 end = data + itmsz * nitm;
9709 retval = (int) nitm; /* on success return # items written */
9712 while (cpd <= end) {
9713 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9714 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9716 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9720 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9723 } /* end of my_fwrite() */
9726 /*{{{ int my_flush(FILE *fp)*/
9728 Perl_my_flush(pTHX_ FILE *fp)
9731 if ((res = fflush(fp)) == 0 && fp) {
9732 #ifdef VMS_DO_SOCKETS
9734 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9736 res = fsync(fileno(fp));
9739 * If the flush succeeded but set end-of-file, we need to clear
9740 * the error because our caller may check ferror(). BTW, this
9741 * probably means we just flushed an empty file.
9743 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9750 * Here are replacements for the following Unix routines in the VMS environment:
9751 * getpwuid Get information for a particular UIC or UID
9752 * getpwnam Get information for a named user
9753 * getpwent Get information for each user in the rights database
9754 * setpwent Reset search to the start of the rights database
9755 * endpwent Finish searching for users in the rights database
9757 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9758 * (defined in pwd.h), which contains the following fields:-
9760 * char *pw_name; Username (in lower case)
9761 * char *pw_passwd; Hashed password
9762 * unsigned int pw_uid; UIC
9763 * unsigned int pw_gid; UIC group number
9764 * char *pw_unixdir; Default device/directory (VMS-style)
9765 * char *pw_gecos; Owner name
9766 * char *pw_dir; Default device/directory (Unix-style)
9767 * char *pw_shell; Default CLI name (eg. DCL)
9769 * If the specified user does not exist, getpwuid and getpwnam return NULL.
9771 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9772 * not the UIC member number (eg. what's returned by getuid()),
9773 * getpwuid() can accept either as input (if uid is specified, the caller's
9774 * UIC group is used), though it won't recognise gid=0.
9776 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9777 * information about other users in your group or in other groups, respectively.
9778 * If the required privilege is not available, then these routines fill only
9779 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9782 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9785 /* sizes of various UAF record fields */
9786 #define UAI$S_USERNAME 12
9787 #define UAI$S_IDENT 31
9788 #define UAI$S_OWNER 31
9789 #define UAI$S_DEFDEV 31
9790 #define UAI$S_DEFDIR 63
9791 #define UAI$S_DEFCLI 31
9794 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
9795 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9796 (uic).uic$v_group != UIC$K_WILD_GROUP)
9798 static char __empty[]= "";
9799 static struct passwd __passwd_empty=
9800 {(char *) __empty, (char *) __empty, 0, 0,
9801 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9802 static int contxt= 0;
9803 static struct passwd __pwdcache;
9804 static char __pw_namecache[UAI$S_IDENT+1];
9807 * This routine does most of the work extracting the user information.
9809 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9812 unsigned char length;
9813 char pw_gecos[UAI$S_OWNER+1];
9815 static union uicdef uic;
9817 unsigned char length;
9818 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9821 unsigned char length;
9822 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9825 unsigned char length;
9826 char pw_shell[UAI$S_DEFCLI+1];
9828 static char pw_passwd[UAI$S_PWD+1];
9830 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9831 struct dsc$descriptor_s name_desc;
9832 unsigned long int sts;
9834 static struct itmlst_3 itmlst[]= {
9835 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
9836 {sizeof(uic), UAI$_UIC, &uic, &luic},
9837 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
9838 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
9839 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
9840 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
9841 {0, 0, NULL, NULL}};
9843 name_desc.dsc$w_length= strlen(name);
9844 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9845 name_desc.dsc$b_class= DSC$K_CLASS_S;
9846 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9848 /* Note that sys$getuai returns many fields as counted strings. */
9849 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9850 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9851 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9853 else { _ckvmssts(sts); }
9854 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
9856 if ((int) owner.length < lowner) lowner= (int) owner.length;
9857 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9858 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9859 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9860 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9861 owner.pw_gecos[lowner]= '\0';
9862 defdev.pw_dir[ldefdev+ldefdir]= '\0';
9863 defcli.pw_shell[ldefcli]= '\0';
9864 if (valid_uic(uic)) {
9865 pwd->pw_uid= uic.uic$l_uic;
9866 pwd->pw_gid= uic.uic$v_group;
9869 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9870 pwd->pw_passwd= pw_passwd;
9871 pwd->pw_gecos= owner.pw_gecos;
9872 pwd->pw_dir= defdev.pw_dir;
9873 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9874 pwd->pw_shell= defcli.pw_shell;
9875 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9877 ldir= strlen(pwd->pw_unixdir) - 1;
9878 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9881 strcpy(pwd->pw_unixdir, pwd->pw_dir);
9882 if (!decc_efs_case_preserve)
9883 __mystrtolower(pwd->pw_unixdir);
9888 * Get information for a named user.
9890 /*{{{struct passwd *getpwnam(char *name)*/
9891 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9893 struct dsc$descriptor_s name_desc;
9895 unsigned long int status, sts;
9897 __pwdcache = __passwd_empty;
9898 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9899 /* We still may be able to determine pw_uid and pw_gid */
9900 name_desc.dsc$w_length= strlen(name);
9901 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9902 name_desc.dsc$b_class= DSC$K_CLASS_S;
9903 name_desc.dsc$a_pointer= (char *) name;
9904 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9905 __pwdcache.pw_uid= uic.uic$l_uic;
9906 __pwdcache.pw_gid= uic.uic$v_group;
9909 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9910 set_vaxc_errno(sts);
9911 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9914 else { _ckvmssts(sts); }
9917 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9918 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9919 __pwdcache.pw_name= __pw_namecache;
9921 } /* end of my_getpwnam() */
9925 * Get information for a particular UIC or UID.
9926 * Called by my_getpwent with uid=-1 to list all users.
9928 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9929 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9931 const $DESCRIPTOR(name_desc,__pw_namecache);
9932 unsigned short lname;
9934 unsigned long int status;
9936 if (uid == (unsigned int) -1) {
9938 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9939 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9940 set_vaxc_errno(status);
9941 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9945 else { _ckvmssts(status); }
9946 } while (!valid_uic (uic));
9950 if (!uic.uic$v_group)
9951 uic.uic$v_group= PerlProc_getgid();
9953 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9954 else status = SS$_IVIDENT;
9955 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9956 status == RMS$_PRV) {
9957 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9960 else { _ckvmssts(status); }
9962 __pw_namecache[lname]= '\0';
9963 __mystrtolower(__pw_namecache);
9965 __pwdcache = __passwd_empty;
9966 __pwdcache.pw_name = __pw_namecache;
9968 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9969 The identifier's value is usually the UIC, but it doesn't have to be,
9970 so if we can, we let fillpasswd update this. */
9971 __pwdcache.pw_uid = uic.uic$l_uic;
9972 __pwdcache.pw_gid = uic.uic$v_group;
9974 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9977 } /* end of my_getpwuid() */
9981 * Get information for next user.
9983 /*{{{struct passwd *my_getpwent()*/
9984 struct passwd *Perl_my_getpwent(pTHX)
9986 return (my_getpwuid((unsigned int) -1));
9991 * Finish searching rights database for users.
9993 /*{{{void my_endpwent()*/
9994 void Perl_my_endpwent(pTHX)
9997 _ckvmssts(sys$finish_rdb(&contxt));
10003 #ifdef HOMEGROWN_POSIX_SIGNALS
10004 /* Signal handling routines, pulled into the core from POSIX.xs.
10006 * We need these for threads, so they've been rolled into the core,
10007 * rather than left in POSIX.xs.
10009 * (DRS, Oct 23, 1997)
10012 /* sigset_t is atomic under VMS, so these routines are easy */
10013 /*{{{int my_sigemptyset(sigset_t *) */
10014 int my_sigemptyset(sigset_t *set) {
10015 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10016 *set = 0; return 0;
10021 /*{{{int my_sigfillset(sigset_t *)*/
10022 int my_sigfillset(sigset_t *set) {
10024 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10025 for (i = 0; i < NSIG; i++) *set |= (1 << i);
10031 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10032 int my_sigaddset(sigset_t *set, int sig) {
10033 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10034 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10035 *set |= (1 << (sig - 1));
10041 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10042 int my_sigdelset(sigset_t *set, int sig) {
10043 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10044 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10045 *set &= ~(1 << (sig - 1));
10051 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10052 int my_sigismember(sigset_t *set, int sig) {
10053 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10054 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10055 return *set & (1 << (sig - 1));
10060 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10061 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10064 /* If set and oset are both null, then things are badly wrong. Bail out. */
10065 if ((oset == NULL) && (set == NULL)) {
10066 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10070 /* If set's null, then we're just handling a fetch. */
10072 tempmask = sigblock(0);
10077 tempmask = sigsetmask(*set);
10080 tempmask = sigblock(*set);
10083 tempmask = sigblock(0);
10084 sigsetmask(*oset & ~tempmask);
10087 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10092 /* Did they pass us an oset? If so, stick our holding mask into it */
10099 #endif /* HOMEGROWN_POSIX_SIGNALS */
10102 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10103 * my_utime(), and flex_stat(), all of which operate on UTC unless
10104 * VMSISH_TIMES is true.
10106 /* method used to handle UTC conversions:
10107 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
10109 static int gmtime_emulation_type;
10110 /* number of secs to add to UTC POSIX-style time to get local time */
10111 static long int utc_offset_secs;
10113 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10114 * in vmsish.h. #undef them here so we can call the CRTL routines
10123 * DEC C previous to 6.0 corrupts the behavior of the /prefix
10124 * qualifier with the extern prefix pragma. This provisional
10125 * hack circumvents this prefix pragma problem in previous
10128 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10129 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10130 # pragma __extern_prefix save
10131 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
10132 # define gmtime decc$__utctz_gmtime
10133 # define localtime decc$__utctz_localtime
10134 # define time decc$__utc_time
10135 # pragma __extern_prefix restore
10137 struct tm *gmtime(), *localtime();
10143 static time_t toutc_dst(time_t loc) {
10146 if ((rsltmp = localtime(&loc)) == NULL) return -1;
10147 loc -= utc_offset_secs;
10148 if (rsltmp->tm_isdst) loc -= 3600;
10151 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10152 ((gmtime_emulation_type || my_time(NULL)), \
10153 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10154 ((secs) - utc_offset_secs))))
10156 static time_t toloc_dst(time_t utc) {
10159 utc += utc_offset_secs;
10160 if ((rsltmp = localtime(&utc)) == NULL) return -1;
10161 if (rsltmp->tm_isdst) utc += 3600;
10164 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10165 ((gmtime_emulation_type || my_time(NULL)), \
10166 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10167 ((secs) + utc_offset_secs))))
10169 #ifndef RTL_USES_UTC
10172 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
10173 DST starts on 1st sun of april at 02:00 std time
10174 ends on last sun of october at 02:00 dst time
10175 see the UCX management command reference, SET CONFIG TIMEZONE
10176 for formatting info.
10178 No, it's not as general as it should be, but then again, NOTHING
10179 will handle UK times in a sensible way.
10184 parse the DST start/end info:
10185 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10189 tz_parse_startend(char *s, struct tm *w, int *past)
10191 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10192 int ly, dozjd, d, m, n, hour, min, sec, j, k;
10197 if (!past) return 0;
10200 if (w->tm_year % 4 == 0) ly = 1;
10201 if (w->tm_year % 100 == 0) ly = 0;
10202 if (w->tm_year+1900 % 400 == 0) ly = 1;
10205 dozjd = isdigit(*s);
10206 if (*s == 'J' || *s == 'j' || dozjd) {
10207 if (!dozjd && !isdigit(*++s)) return 0;
10210 d = d*10 + *s++ - '0';
10212 d = d*10 + *s++ - '0';
10215 if (d == 0) return 0;
10216 if (d > 366) return 0;
10218 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
10221 } else if (*s == 'M' || *s == 'm') {
10222 if (!isdigit(*++s)) return 0;
10224 if (isdigit(*s)) m = 10*m + *s++ - '0';
10225 if (*s != '.') return 0;
10226 if (!isdigit(*++s)) return 0;
10228 if (n < 1 || n > 5) return 0;
10229 if (*s != '.') return 0;
10230 if (!isdigit(*++s)) return 0;
10232 if (d > 6) return 0;
10236 if (!isdigit(*++s)) return 0;
10238 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10240 if (!isdigit(*++s)) return 0;
10242 if (isdigit(*s)) min = 10*min + *s++ - '0';
10244 if (!isdigit(*++s)) return 0;
10246 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10256 if (w->tm_yday < d) goto before;
10257 if (w->tm_yday > d) goto after;
10259 if (w->tm_mon+1 < m) goto before;
10260 if (w->tm_mon+1 > m) goto after;
10262 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
10263 k = d - j; /* mday of first d */
10264 if (k <= 0) k += 7;
10265 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
10266 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10267 if (w->tm_mday < k) goto before;
10268 if (w->tm_mday > k) goto after;
10271 if (w->tm_hour < hour) goto before;
10272 if (w->tm_hour > hour) goto after;
10273 if (w->tm_min < min) goto before;
10274 if (w->tm_min > min) goto after;
10275 if (w->tm_sec < sec) goto before;
10289 /* parse the offset: (+|-)hh[:mm[:ss]] */
10292 tz_parse_offset(char *s, int *offset)
10294 int hour = 0, min = 0, sec = 0;
10297 if (!offset) return 0;
10299 if (*s == '-') {neg++; s++;}
10300 if (*s == '+') s++;
10301 if (!isdigit(*s)) return 0;
10303 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10304 if (hour > 24) return 0;
10306 if (!isdigit(*++s)) return 0;
10308 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10309 if (min > 59) return 0;
10311 if (!isdigit(*++s)) return 0;
10313 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10314 if (sec > 59) return 0;
10318 *offset = (hour*60+min)*60 + sec;
10319 if (neg) *offset = -*offset;
10324 input time is w, whatever type of time the CRTL localtime() uses.
10325 sets dst, the zone, and the gmtoff (seconds)
10327 caches the value of TZ and UCX$TZ env variables; note that
10328 my_setenv looks for these and sets a flag if they're changed
10331 We have to watch out for the "australian" case (dst starts in
10332 october, ends in april)...flagged by "reverse" and checked by
10333 scanning through the months of the previous year.
10338 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10343 char *dstzone, *tz, *s_start, *s_end;
10344 int std_off, dst_off, isdst;
10345 int y, dststart, dstend;
10346 static char envtz[1025]; /* longer than any logical, symbol, ... */
10347 static char ucxtz[1025];
10348 static char reversed = 0;
10354 reversed = -1; /* flag need to check */
10355 envtz[0] = ucxtz[0] = '\0';
10356 tz = my_getenv("TZ",0);
10357 if (tz) strcpy(envtz, tz);
10358 tz = my_getenv("UCX$TZ",0);
10359 if (tz) strcpy(ucxtz, tz);
10360 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
10363 if (!*tz) tz = ucxtz;
10366 while (isalpha(*s)) s++;
10367 s = tz_parse_offset(s, &std_off);
10369 if (!*s) { /* no DST, hurray we're done! */
10375 while (isalpha(*s)) s++;
10376 s2 = tz_parse_offset(s, &dst_off);
10380 dst_off = std_off - 3600;
10383 if (!*s) { /* default dst start/end?? */
10384 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
10385 s = strchr(ucxtz,',');
10387 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
10389 if (*s != ',') return 0;
10392 when = _toutc(when); /* convert to utc */
10393 when = when - std_off; /* convert to pseudolocal time*/
10395 w2 = localtime(&when);
10398 s = tz_parse_startend(s_start,w2,&dststart);
10400 if (*s != ',') return 0;
10403 when = _toutc(when); /* convert to utc */
10404 when = when - dst_off; /* convert to pseudolocal time*/
10405 w2 = localtime(&when);
10406 if (w2->tm_year != y) { /* spans a year, just check one time */
10407 when += dst_off - std_off;
10408 w2 = localtime(&when);
10411 s = tz_parse_startend(s_end,w2,&dstend);
10414 if (reversed == -1) { /* need to check if start later than end */
10418 if (when < 2*365*86400) {
10419 when += 2*365*86400;
10423 w2 =localtime(&when);
10424 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
10426 for (j = 0; j < 12; j++) {
10427 w2 =localtime(&when);
10428 tz_parse_startend(s_start,w2,&ds);
10429 tz_parse_startend(s_end,w2,&de);
10430 if (ds != de) break;
10434 if (de && !ds) reversed = 1;
10437 isdst = dststart && !dstend;
10438 if (reversed) isdst = dststart || !dstend;
10441 if (dst) *dst = isdst;
10442 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10443 if (isdst) tz = dstzone;
10445 while(isalpha(*tz)) *zone++ = *tz++;
10451 #endif /* !RTL_USES_UTC */
10453 /* my_time(), my_localtime(), my_gmtime()
10454 * By default traffic in UTC time values, using CRTL gmtime() or
10455 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10456 * Note: We need to use these functions even when the CRTL has working
10457 * UTC support, since they also handle C<use vmsish qw(times);>
10459 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
10460 * Modified by Charles Bailey <bailey@newman.upenn.edu>
10463 /*{{{time_t my_time(time_t *timep)*/
10464 time_t Perl_my_time(pTHX_ time_t *timep)
10469 if (gmtime_emulation_type == 0) {
10471 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
10472 /* results of calls to gmtime() and localtime() */
10473 /* for same &base */
10475 gmtime_emulation_type++;
10476 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10477 char off[LNM$C_NAMLENGTH+1];;
10479 gmtime_emulation_type++;
10480 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10481 gmtime_emulation_type++;
10482 utc_offset_secs = 0;
10483 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10485 else { utc_offset_secs = atol(off); }
10487 else { /* We've got a working gmtime() */
10488 struct tm gmt, local;
10491 tm_p = localtime(&base);
10493 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
10494 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10495 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
10496 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
10501 # ifdef VMSISH_TIME
10502 # ifdef RTL_USES_UTC
10503 if (VMSISH_TIME) when = _toloc(when);
10505 if (!VMSISH_TIME) when = _toutc(when);
10508 if (timep != NULL) *timep = when;
10511 } /* end of my_time() */
10515 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10517 Perl_my_gmtime(pTHX_ const time_t *timep)
10523 if (timep == NULL) {
10524 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10527 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10530 # ifdef VMSISH_TIME
10531 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10533 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
10534 return gmtime(&when);
10536 /* CRTL localtime() wants local time as input, so does no tz correction */
10537 rsltmp = localtime(&when);
10538 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
10541 } /* end of my_gmtime() */
10545 /*{{{struct tm *my_localtime(const time_t *timep)*/
10547 Perl_my_localtime(pTHX_ const time_t *timep)
10549 time_t when, whenutc;
10553 if (timep == NULL) {
10554 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10557 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10558 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10561 # ifdef RTL_USES_UTC
10562 # ifdef VMSISH_TIME
10563 if (VMSISH_TIME) when = _toutc(when);
10565 /* CRTL localtime() wants UTC as input, does tz correction itself */
10566 return localtime(&when);
10568 # else /* !RTL_USES_UTC */
10570 # ifdef VMSISH_TIME
10571 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
10572 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
10575 #ifndef RTL_USES_UTC
10576 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
10577 when = whenutc - offset; /* pseudolocal time*/
10580 /* CRTL localtime() wants local time as input, so does no tz correction */
10581 rsltmp = localtime(&when);
10582 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10586 } /* end of my_localtime() */
10589 /* Reset definitions for later calls */
10590 #define gmtime(t) my_gmtime(t)
10591 #define localtime(t) my_localtime(t)
10592 #define time(t) my_time(t)
10595 /* my_utime - update modification/access time of a file
10597 * VMS 7.3 and later implementation
10598 * Only the UTC translation is home-grown. The rest is handled by the
10599 * CRTL utime(), which will take into account the relevant feature
10600 * logicals and ODS-5 volume characteristics for true access times.
10602 * pre VMS 7.3 implementation:
10603 * The calling sequence is identical to POSIX utime(), but under
10604 * VMS with ODS-2, only the modification time is changed; ODS-2 does
10605 * not maintain access times. Restrictions differ from the POSIX
10606 * definition in that the time can be changed as long as the
10607 * caller has permission to execute the necessary IO$_MODIFY $QIO;
10608 * no separate checks are made to insure that the caller is the
10609 * owner of the file or has special privs enabled.
10610 * Code here is based on Joe Meadows' FILE utility.
10614 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10615 * to VMS epoch (01-JAN-1858 00:00:00.00)
10616 * in 100 ns intervals.
10618 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10620 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10621 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10623 #if __CRTL_VER >= 70300000
10624 struct utimbuf utc_utimes, *utc_utimesp;
10626 if (utimes != NULL) {
10627 utc_utimes.actime = utimes->actime;
10628 utc_utimes.modtime = utimes->modtime;
10629 # ifdef VMSISH_TIME
10630 /* If input was local; convert to UTC for sys svc */
10632 utc_utimes.actime = _toutc(utimes->actime);
10633 utc_utimes.modtime = _toutc(utimes->modtime);
10636 utc_utimesp = &utc_utimes;
10639 utc_utimesp = NULL;
10642 return utime(file, utc_utimesp);
10644 #else /* __CRTL_VER < 70300000 */
10648 long int bintime[2], len = 2, lowbit, unixtime,
10649 secscale = 10000000; /* seconds --> 100 ns intervals */
10650 unsigned long int chan, iosb[2], retsts;
10651 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10652 struct FAB myfab = cc$rms_fab;
10653 struct NAM mynam = cc$rms_nam;
10654 #if defined (__DECC) && defined (__VAX)
10655 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10656 * at least through VMS V6.1, which causes a type-conversion warning.
10658 # pragma message save
10659 # pragma message disable cvtdiftypes
10661 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10662 struct fibdef myfib;
10663 #if defined (__DECC) && defined (__VAX)
10664 /* This should be right after the declaration of myatr, but due
10665 * to a bug in VAX DEC C, this takes effect a statement early.
10667 # pragma message restore
10669 /* cast ok for read only parameter */
10670 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10671 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10672 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10674 if (file == NULL || *file == '\0') {
10675 SETERRNO(ENOENT, LIB$_INVARG);
10679 /* Convert to VMS format ensuring that it will fit in 255 characters */
10680 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10681 SETERRNO(ENOENT, LIB$_INVARG);
10684 if (utimes != NULL) {
10685 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
10686 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10687 * Since time_t is unsigned long int, and lib$emul takes a signed long int
10688 * as input, we force the sign bit to be clear by shifting unixtime right
10689 * one bit, then multiplying by an extra factor of 2 in lib$emul().
10691 lowbit = (utimes->modtime & 1) ? secscale : 0;
10692 unixtime = (long int) utimes->modtime;
10693 # ifdef VMSISH_TIME
10694 /* If input was UTC; convert to local for sys svc */
10695 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10697 unixtime >>= 1; secscale <<= 1;
10698 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10699 if (!(retsts & 1)) {
10700 SETERRNO(EVMSERR, retsts);
10703 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10704 if (!(retsts & 1)) {
10705 SETERRNO(EVMSERR, retsts);
10710 /* Just get the current time in VMS format directly */
10711 retsts = sys$gettim(bintime);
10712 if (!(retsts & 1)) {
10713 SETERRNO(EVMSERR, retsts);
10718 myfab.fab$l_fna = vmsspec;
10719 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10720 myfab.fab$l_nam = &mynam;
10721 mynam.nam$l_esa = esa;
10722 mynam.nam$b_ess = (unsigned char) sizeof esa;
10723 mynam.nam$l_rsa = rsa;
10724 mynam.nam$b_rss = (unsigned char) sizeof rsa;
10725 if (decc_efs_case_preserve)
10726 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10728 /* Look for the file to be affected, letting RMS parse the file
10729 * specification for us as well. I have set errno using only
10730 * values documented in the utime() man page for VMS POSIX.
10732 retsts = sys$parse(&myfab,0,0);
10733 if (!(retsts & 1)) {
10734 set_vaxc_errno(retsts);
10735 if (retsts == RMS$_PRV) set_errno(EACCES);
10736 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10737 else set_errno(EVMSERR);
10740 retsts = sys$search(&myfab,0,0);
10741 if (!(retsts & 1)) {
10742 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10743 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10744 set_vaxc_errno(retsts);
10745 if (retsts == RMS$_PRV) set_errno(EACCES);
10746 else if (retsts == RMS$_FNF) set_errno(ENOENT);
10747 else set_errno(EVMSERR);
10751 devdsc.dsc$w_length = mynam.nam$b_dev;
10752 /* cast ok for read only parameter */
10753 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10755 retsts = sys$assign(&devdsc,&chan,0,0);
10756 if (!(retsts & 1)) {
10757 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10758 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10759 set_vaxc_errno(retsts);
10760 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
10761 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
10762 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
10763 else set_errno(EVMSERR);
10767 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10768 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10770 memset((void *) &myfib, 0, sizeof myfib);
10771 #if defined(__DECC) || defined(__DECCXX)
10772 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10773 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10774 /* This prevents the revision time of the file being reset to the current
10775 * time as a result of our IO$_MODIFY $QIO. */
10776 myfib.fib$l_acctl = FIB$M_NORECORD;
10778 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10779 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10780 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10782 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10783 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10784 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10785 _ckvmssts(sys$dassgn(chan));
10786 if (retsts & 1) retsts = iosb[0];
10787 if (!(retsts & 1)) {
10788 set_vaxc_errno(retsts);
10789 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10790 else set_errno(EVMSERR);
10796 #endif /* #if __CRTL_VER >= 70300000 */
10798 } /* end of my_utime() */
10802 * flex_stat, flex_lstat, flex_fstat
10803 * basic stat, but gets it right when asked to stat
10804 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10807 #ifndef _USE_STD_STAT
10808 /* encode_dev packs a VMS device name string into an integer to allow
10809 * simple comparisons. This can be used, for example, to check whether two
10810 * files are located on the same device, by comparing their encoded device
10811 * names. Even a string comparison would not do, because stat() reuses the
10812 * device name buffer for each call; so without encode_dev, it would be
10813 * necessary to save the buffer and use strcmp (this would mean a number of
10814 * changes to the standard Perl code, to say nothing of what a Perl script
10815 * would have to do.
10817 * The device lock id, if it exists, should be unique (unless perhaps compared
10818 * with lock ids transferred from other nodes). We have a lock id if the disk is
10819 * mounted cluster-wide, which is when we tend to get long (host-qualified)
10820 * device names. Thus we use the lock id in preference, and only if that isn't
10821 * available, do we try to pack the device name into an integer (flagged by
10822 * the sign bit (LOCKID_MASK) being set).
10824 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10825 * name and its encoded form, but it seems very unlikely that we will find
10826 * two files on different disks that share the same encoded device names,
10827 * and even more remote that they will share the same file id (if the test
10828 * is to check for the same file).
10830 * A better method might be to use sys$device_scan on the first call, and to
10831 * search for the device, returning an index into the cached array.
10832 * The number returned would be more intelligible.
10833 * This is probably not worth it, and anyway would take quite a bit longer
10834 * on the first call.
10836 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
10837 static mydev_t encode_dev (pTHX_ const char *dev)
10840 unsigned long int f;
10845 if (!dev || !dev[0]) return 0;
10849 struct dsc$descriptor_s dev_desc;
10850 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10852 /* For cluster-mounted disks, the disk lock identifier is unique, so we
10853 can try that first. */
10854 dev_desc.dsc$w_length = strlen (dev);
10855 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
10856 dev_desc.dsc$b_class = DSC$K_CLASS_S;
10857 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
10858 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10859 if (!$VMS_STATUS_SUCCESS(status)) {
10861 case SS$_NOSUCHDEV:
10862 SETERRNO(ENODEV, status);
10868 if (lockid) return (lockid & ~LOCKID_MASK);
10872 /* Otherwise we try to encode the device name */
10876 for (q = dev + strlen(dev); q--; q >= dev) {
10881 else if (isalpha (toupper (*q)))
10882 c= toupper (*q) - 'A' + (char)10;
10884 continue; /* Skip '$'s */
10886 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
10888 enc += f * (unsigned long int) c;
10890 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
10892 } /* end of encode_dev() */
10893 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10894 device_no = encode_dev(aTHX_ devname)
10896 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10897 device_no = new_dev_no
10901 is_null_device(name)
10904 if (decc_bug_devnull != 0) {
10905 if (strncmp("/dev/null", name, 9) == 0)
10908 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10909 The underscore prefix, controller letter, and unit number are
10910 independently optional; for our purposes, the colon punctuation
10911 is not. The colon can be trailed by optional directory and/or
10912 filename, but two consecutive colons indicates a nodename rather
10913 than a device. [pr] */
10914 if (*name == '_') ++name;
10915 if (tolower(*name++) != 'n') return 0;
10916 if (tolower(*name++) != 'l') return 0;
10917 if (tolower(*name) == 'a') ++name;
10918 if (*name == '0') ++name;
10919 return (*name++ == ':') && (*name != ':');
10924 Perl_cando_by_name_int
10925 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10927 static char usrname[L_cuserid];
10928 static struct dsc$descriptor_s usrdsc =
10929 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10930 char vmsname[NAM$C_MAXRSS+1];
10932 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10933 unsigned short int retlen, trnlnm_iter_count;
10934 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10935 union prvdef curprv;
10936 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10937 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10938 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10939 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10940 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10942 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10944 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10946 if (!fname || !*fname) return FALSE;
10947 /* Make sure we expand logical names, since sys$check_access doesn't */
10950 if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10951 fileified = PerlMem_malloc(VMS_MAXRSS);
10952 if (!strpbrk(fname,"/]>:")) {
10953 strcpy(fileified,fname);
10954 trnlnm_iter_count = 0;
10955 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10956 trnlnm_iter_count++;
10957 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10961 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10962 PerlMem_free(fileified);
10965 retlen = namdsc.dsc$w_length = strlen(vmsname);
10966 namdsc.dsc$a_pointer = vmsname;
10967 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10968 vmsname[retlen-1] == ':') {
10969 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10970 namdsc.dsc$w_length = strlen(fileified);
10971 namdsc.dsc$a_pointer = fileified;
10975 retlen = namdsc.dsc$w_length = strlen(fname);
10976 namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10980 case S_IXUSR: case S_IXGRP: case S_IXOTH:
10981 access = ARM$M_EXECUTE;
10982 flags = CHP$M_READ;
10984 case S_IRUSR: case S_IRGRP: case S_IROTH:
10985 access = ARM$M_READ;
10986 flags = CHP$M_READ | CHP$M_USEREADALL;
10988 case S_IWUSR: case S_IWGRP: case S_IWOTH:
10989 access = ARM$M_WRITE;
10990 flags = CHP$M_READ | CHP$M_WRITE;
10992 case S_IDUSR: case S_IDGRP: case S_IDOTH:
10993 access = ARM$M_DELETE;
10994 flags = CHP$M_READ | CHP$M_WRITE;
10997 if (fileified != NULL)
10998 PerlMem_free(fileified);
11002 /* Before we call $check_access, create a user profile with the current
11003 * process privs since otherwise it just uses the default privs from the
11004 * UAF and might give false positives or negatives. This only works on
11005 * VMS versions v6.0 and later since that's when sys$create_user_profile
11006 * became available.
11009 /* get current process privs and username */
11010 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11011 _ckvmssts(iosb[0]);
11013 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11015 /* find out the space required for the profile */
11016 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11017 &usrprodsc.dsc$w_length,0));
11019 /* allocate space for the profile and get it filled in */
11020 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11021 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11022 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11023 &usrprodsc.dsc$w_length,0));
11025 /* use the profile to check access to the file; free profile & analyze results */
11026 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
11027 PerlMem_free(usrprodsc.dsc$a_pointer);
11028 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11032 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11036 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
11037 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11038 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11039 set_vaxc_errno(retsts);
11040 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11041 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11042 else set_errno(ENOENT);
11043 if (fileified != NULL)
11044 PerlMem_free(fileified);
11047 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11048 if (fileified != NULL)
11049 PerlMem_free(fileified);
11054 if (fileified != NULL)
11055 PerlMem_free(fileified);
11056 return FALSE; /* Should never get here */
11060 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
11061 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11062 * subset of the applicable information.
11065 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11067 return cando_by_name_int
11068 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11069 } /* end of cando() */
11073 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11075 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11077 return cando_by_name_int(bit, effective, fname, 0);
11079 } /* end of cando_by_name() */
11083 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11085 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11087 if (!fstat(fd,(stat_t *) statbufp)) {
11089 char *vms_filename;
11090 vms_filename = PerlMem_malloc(VMS_MAXRSS);
11091 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11093 /* Save name for cando by name in VMS format */
11094 cptr = getname(fd, vms_filename, 1);
11096 /* This should not happen, but just in case */
11097 if (cptr == NULL) {
11098 statbufp->st_devnam[0] = 0;
11101 /* Make sure that the saved name fits in 255 characters */
11102 cptr = do_rmsexpand
11104 statbufp->st_devnam,
11107 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11111 statbufp->st_devnam[0] = 0;
11113 PerlMem_free(vms_filename);
11115 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11117 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11119 # ifdef RTL_USES_UTC
11120 # ifdef VMSISH_TIME
11122 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11123 statbufp->st_atime = _toloc(statbufp->st_atime);
11124 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11128 # ifdef VMSISH_TIME
11129 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11133 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11134 statbufp->st_atime = _toutc(statbufp->st_atime);
11135 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11142 } /* end of flex_fstat() */
11145 #if !defined(__VAX) && __CRTL_VER >= 80200000
11153 #define lstat(_x, _y) stat(_x, _y)
11156 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11159 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11161 char fileified[VMS_MAXRSS];
11162 char temp_fspec[VMS_MAXRSS];
11165 int saved_errno, saved_vaxc_errno;
11167 if (!fspec) return retval;
11168 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11169 strcpy(temp_fspec, fspec);
11171 if (decc_bug_devnull != 0) {
11172 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11173 memset(statbufp,0,sizeof *statbufp);
11174 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11175 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11176 statbufp->st_uid = 0x00010001;
11177 statbufp->st_gid = 0x0001;
11178 time((time_t *)&statbufp->st_mtime);
11179 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11184 /* Try for a directory name first. If fspec contains a filename without
11185 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11186 * and sea:[wine.dark]water. exist, we prefer the directory here.
11187 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11188 * not sea:[wine.dark]., if the latter exists. If the intended target is
11189 * the file with null type, specify this by calling flex_stat() with
11190 * a '.' at the end of fspec.
11192 * If we are in Posix filespec mode, accept the filename as is.
11194 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11195 if (decc_posix_compliant_pathnames == 0) {
11197 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11198 if (lstat_flag == 0)
11199 retval = stat(fileified,(stat_t *) statbufp);
11201 retval = lstat(fileified,(stat_t *) statbufp);
11202 save_spec = fileified;
11205 if (lstat_flag == 0)
11206 retval = stat(temp_fspec,(stat_t *) statbufp);
11208 retval = lstat(temp_fspec,(stat_t *) statbufp);
11209 save_spec = temp_fspec;
11211 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11213 if (lstat_flag == 0)
11214 retval = stat(temp_fspec,(stat_t *) statbufp);
11216 retval = lstat(temp_fspec,(stat_t *) statbufp);
11217 save_spec = temp_fspec;
11222 cptr = do_rmsexpand
11223 (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11225 statbufp->st_devnam[0] = 0;
11227 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11229 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11230 # ifdef RTL_USES_UTC
11231 # ifdef VMSISH_TIME
11233 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11234 statbufp->st_atime = _toloc(statbufp->st_atime);
11235 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11239 # ifdef VMSISH_TIME
11240 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11244 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11245 statbufp->st_atime = _toutc(statbufp->st_atime);
11246 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11250 /* If we were successful, leave errno where we found it */
11251 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11254 } /* end of flex_stat_int() */
11257 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11259 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11261 return flex_stat_int(fspec, statbufp, 0);
11265 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11267 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11269 return flex_stat_int(fspec, statbufp, 1);
11274 /*{{{char *my_getlogin()*/
11275 /* VMS cuserid == Unix getlogin, except calling sequence */
11279 static char user[L_cuserid];
11280 return cuserid(user);
11285 /* rmscopy - copy a file using VMS RMS routines
11287 * Copies contents and attributes of spec_in to spec_out, except owner
11288 * and protection information. Name and type of spec_in are used as
11289 * defaults for spec_out. The third parameter specifies whether rmscopy()
11290 * should try to propagate timestamps from the input file to the output file.
11291 * If it is less than 0, no timestamps are preserved. If it is 0, then
11292 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
11293 * propagated to the output file at creation iff the output file specification
11294 * did not contain an explicit name or type, and the revision date is always
11295 * updated at the end of the copy operation. If it is greater than 0, then
11296 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11297 * other than the revision date should be propagated, and bit 1 indicates
11298 * that the revision date should be propagated.
11300 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11302 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11303 * Incorporates, with permission, some code from EZCOPY by Tim Adye
11304 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
11305 * as part of the Perl standard distribution under the terms of the
11306 * GNU General Public License or the Perl Artistic License. Copies
11307 * of each may be found in the Perl standard distribution.
11309 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11311 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11313 char *vmsin, * vmsout, *esa, *esa_out,
11315 unsigned long int i, sts, sts2;
11317 struct FAB fab_in, fab_out;
11318 struct RAB rab_in, rab_out;
11319 rms_setup_nam(nam);
11320 rms_setup_nam(nam_out);
11321 struct XABDAT xabdat;
11322 struct XABFHC xabfhc;
11323 struct XABRDT xabrdt;
11324 struct XABSUM xabsum;
11326 vmsin = PerlMem_malloc(VMS_MAXRSS);
11327 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11328 vmsout = PerlMem_malloc(VMS_MAXRSS);
11329 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11330 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11331 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11332 PerlMem_free(vmsin);
11333 PerlMem_free(vmsout);
11334 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11338 esa = PerlMem_malloc(VMS_MAXRSS);
11339 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11340 fab_in = cc$rms_fab;
11341 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11342 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11343 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11344 fab_in.fab$l_fop = FAB$M_SQO;
11345 rms_bind_fab_nam(fab_in, nam);
11346 fab_in.fab$l_xab = (void *) &xabdat;
11348 rsa = PerlMem_malloc(VMS_MAXRSS);
11349 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11350 rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11351 rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11352 rms_nam_esl(nam) = 0;
11353 rms_nam_rsl(nam) = 0;
11354 rms_nam_esll(nam) = 0;
11355 rms_nam_rsll(nam) = 0;
11356 #ifdef NAM$M_NO_SHORT_UPCASE
11357 if (decc_efs_case_preserve)
11358 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11361 xabdat = cc$rms_xabdat; /* To get creation date */
11362 xabdat.xab$l_nxt = (void *) &xabfhc;
11364 xabfhc = cc$rms_xabfhc; /* To get record length */
11365 xabfhc.xab$l_nxt = (void *) &xabsum;
11367 xabsum = cc$rms_xabsum; /* To get key and area information */
11369 if (!((sts = sys$open(&fab_in)) & 1)) {
11370 PerlMem_free(vmsin);
11371 PerlMem_free(vmsout);
11374 set_vaxc_errno(sts);
11376 case RMS$_FNF: case RMS$_DNF:
11377 set_errno(ENOENT); break;
11379 set_errno(ENOTDIR); break;
11381 set_errno(ENODEV); break;
11383 set_errno(EINVAL); break;
11385 set_errno(EACCES); break;
11387 set_errno(EVMSERR);
11394 fab_out.fab$w_ifi = 0;
11395 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11396 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11397 fab_out.fab$l_fop = FAB$M_SQO;
11398 rms_bind_fab_nam(fab_out, nam_out);
11399 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11400 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11401 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11402 esa_out = PerlMem_malloc(VMS_MAXRSS);
11403 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11404 rms_set_rsa(nam_out, NULL, 0);
11405 rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11407 if (preserve_dates == 0) { /* Act like DCL COPY */
11408 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11409 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
11410 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11411 PerlMem_free(vmsin);
11412 PerlMem_free(vmsout);
11415 PerlMem_free(esa_out);
11416 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11417 set_vaxc_errno(sts);
11420 fab_out.fab$l_xab = (void *) &xabdat;
11421 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11422 preserve_dates = 1;
11424 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
11425 preserve_dates =0; /* bitmask from this point forward */
11427 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11428 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11429 PerlMem_free(vmsin);
11430 PerlMem_free(vmsout);
11433 PerlMem_free(esa_out);
11434 set_vaxc_errno(sts);
11437 set_errno(ENOENT); break;
11439 set_errno(ENOTDIR); break;
11441 set_errno(ENODEV); break;
11443 set_errno(EINVAL); break;
11445 set_errno(EACCES); break;
11447 set_errno(EVMSERR);
11451 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
11452 if (preserve_dates & 2) {
11453 /* sys$close() will process xabrdt, not xabdat */
11454 xabrdt = cc$rms_xabrdt;
11456 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11458 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11459 * is unsigned long[2], while DECC & VAXC use a struct */
11460 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11462 fab_out.fab$l_xab = (void *) &xabrdt;
11465 ubf = PerlMem_malloc(32256);
11466 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11467 rab_in = cc$rms_rab;
11468 rab_in.rab$l_fab = &fab_in;
11469 rab_in.rab$l_rop = RAB$M_BIO;
11470 rab_in.rab$l_ubf = ubf;
11471 rab_in.rab$w_usz = 32256;
11472 if (!((sts = sys$connect(&rab_in)) & 1)) {
11473 sys$close(&fab_in); sys$close(&fab_out);
11474 PerlMem_free(vmsin);
11475 PerlMem_free(vmsout);
11479 PerlMem_free(esa_out);
11480 set_errno(EVMSERR); set_vaxc_errno(sts);
11484 rab_out = cc$rms_rab;
11485 rab_out.rab$l_fab = &fab_out;
11486 rab_out.rab$l_rbf = ubf;
11487 if (!((sts = sys$connect(&rab_out)) & 1)) {
11488 sys$close(&fab_in); sys$close(&fab_out);
11489 PerlMem_free(vmsin);
11490 PerlMem_free(vmsout);
11494 PerlMem_free(esa_out);
11495 set_errno(EVMSERR); set_vaxc_errno(sts);
11499 while ((sts = sys$read(&rab_in))) { /* always true */
11500 if (sts == RMS$_EOF) break;
11501 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11502 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11503 sys$close(&fab_in); sys$close(&fab_out);
11504 PerlMem_free(vmsin);
11505 PerlMem_free(vmsout);
11509 PerlMem_free(esa_out);
11510 set_errno(EVMSERR); set_vaxc_errno(sts);
11516 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
11517 sys$close(&fab_in); sys$close(&fab_out);
11518 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11520 PerlMem_free(vmsin);
11521 PerlMem_free(vmsout);
11525 PerlMem_free(esa_out);
11526 set_errno(EVMSERR); set_vaxc_errno(sts);
11530 PerlMem_free(vmsin);
11531 PerlMem_free(vmsout);
11535 PerlMem_free(esa_out);
11538 } /* end of rmscopy() */
11542 /*** The following glue provides 'hooks' to make some of the routines
11543 * from this file available from Perl. These routines are sufficiently
11544 * basic, and are required sufficiently early in the build process,
11545 * that's it's nice to have them available to miniperl as well as the
11546 * full Perl, so they're set up here instead of in an extension. The
11547 * Perl code which handles importation of these names into a given
11548 * package lives in [.VMS]Filespec.pm in @INC.
11552 rmsexpand_fromperl(pTHX_ CV *cv)
11555 char *fspec, *defspec = NULL, *rslt;
11557 int fs_utf8, dfs_utf8;
11561 if (!items || items > 2)
11562 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11563 fspec = SvPV(ST(0),n_a);
11564 fs_utf8 = SvUTF8(ST(0));
11565 if (!fspec || !*fspec) XSRETURN_UNDEF;
11567 defspec = SvPV(ST(1),n_a);
11568 dfs_utf8 = SvUTF8(ST(1));
11570 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11571 ST(0) = sv_newmortal();
11572 if (rslt != NULL) {
11573 sv_usepvn(ST(0),rslt,strlen(rslt));
11582 vmsify_fromperl(pTHX_ CV *cv)
11589 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11590 utf8_fl = SvUTF8(ST(0));
11591 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11592 ST(0) = sv_newmortal();
11593 if (vmsified != NULL) {
11594 sv_usepvn(ST(0),vmsified,strlen(vmsified));
11603 unixify_fromperl(pTHX_ CV *cv)
11610 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11611 utf8_fl = SvUTF8(ST(0));
11612 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11613 ST(0) = sv_newmortal();
11614 if (unixified != NULL) {
11615 sv_usepvn(ST(0),unixified,strlen(unixified));
11624 fileify_fromperl(pTHX_ CV *cv)
11631 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11632 utf8_fl = SvUTF8(ST(0));
11633 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11634 ST(0) = sv_newmortal();
11635 if (fileified != NULL) {
11636 sv_usepvn(ST(0),fileified,strlen(fileified));
11645 pathify_fromperl(pTHX_ CV *cv)
11652 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11653 utf8_fl = SvUTF8(ST(0));
11654 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11655 ST(0) = sv_newmortal();
11656 if (pathified != NULL) {
11657 sv_usepvn(ST(0),pathified,strlen(pathified));
11666 vmspath_fromperl(pTHX_ CV *cv)
11673 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11674 utf8_fl = SvUTF8(ST(0));
11675 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11676 ST(0) = sv_newmortal();
11677 if (vmspath != NULL) {
11678 sv_usepvn(ST(0),vmspath,strlen(vmspath));
11687 unixpath_fromperl(pTHX_ CV *cv)
11694 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11695 utf8_fl = SvUTF8(ST(0));
11696 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11697 ST(0) = sv_newmortal();
11698 if (unixpath != NULL) {
11699 sv_usepvn(ST(0),unixpath,strlen(unixpath));
11708 candelete_fromperl(pTHX_ CV *cv)
11716 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11718 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11719 Newx(fspec, VMS_MAXRSS, char);
11720 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11721 if (SvTYPE(mysv) == SVt_PVGV) {
11722 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11723 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11731 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11732 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11739 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11745 rmscopy_fromperl(pTHX_ CV *cv)
11748 char *inspec, *outspec, *inp, *outp;
11750 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11751 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11752 unsigned long int sts;
11757 if (items < 2 || items > 3)
11758 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11760 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11761 Newx(inspec, VMS_MAXRSS, char);
11762 if (SvTYPE(mysv) == SVt_PVGV) {
11763 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11764 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11772 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11773 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11779 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11780 Newx(outspec, VMS_MAXRSS, char);
11781 if (SvTYPE(mysv) == SVt_PVGV) {
11782 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11783 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11792 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11793 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11800 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11802 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11808 /* The mod2fname is limited to shorter filenames by design, so it should
11809 * not be modified to support longer EFS pathnames
11812 mod2fname(pTHX_ CV *cv)
11815 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11816 workbuff[NAM$C_MAXRSS*1 + 1];
11817 int total_namelen = 3, counter, num_entries;
11818 /* ODS-5 ups this, but we want to be consistent, so... */
11819 int max_name_len = 39;
11820 AV *in_array = (AV *)SvRV(ST(0));
11822 num_entries = av_len(in_array);
11824 /* All the names start with PL_. */
11825 strcpy(ultimate_name, "PL_");
11827 /* Clean up our working buffer */
11828 Zero(work_name, sizeof(work_name), char);
11830 /* Run through the entries and build up a working name */
11831 for(counter = 0; counter <= num_entries; counter++) {
11832 /* If it's not the first name then tack on a __ */
11834 strcat(work_name, "__");
11836 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11840 /* Check to see if we actually have to bother...*/
11841 if (strlen(work_name) + 3 <= max_name_len) {
11842 strcat(ultimate_name, work_name);
11844 /* It's too darned big, so we need to go strip. We use the same */
11845 /* algorithm as xsubpp does. First, strip out doubled __ */
11846 char *source, *dest, last;
11849 for (source = work_name; *source; source++) {
11850 if (last == *source && last == '_') {
11856 /* Go put it back */
11857 strcpy(work_name, workbuff);
11858 /* Is it still too big? */
11859 if (strlen(work_name) + 3 > max_name_len) {
11860 /* Strip duplicate letters */
11863 for (source = work_name; *source; source++) {
11864 if (last == toupper(*source)) {
11868 last = toupper(*source);
11870 strcpy(work_name, workbuff);
11873 /* Is it *still* too big? */
11874 if (strlen(work_name) + 3 > max_name_len) {
11875 /* Too bad, we truncate */
11876 work_name[max_name_len - 2] = 0;
11878 strcat(ultimate_name, work_name);
11881 /* Okay, return it */
11882 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11887 hushexit_fromperl(pTHX_ CV *cv)
11892 VMSISH_HUSHED = SvTRUE(ST(0));
11894 ST(0) = boolSV(VMSISH_HUSHED);
11900 Perl_vms_start_glob
11901 (pTHX_ SV *tmpglob,
11905 struct vs_str_st *rslt;
11909 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11912 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11913 struct dsc$descriptor_vs rsdsc;
11914 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11915 unsigned long hasver = 0, isunix = 0;
11916 unsigned long int lff_flags = 0;
11919 #ifdef VMS_LONGNAME_SUPPORT
11920 lff_flags = LIB$M_FIL_LONG_NAMES;
11922 /* The Newx macro will not allow me to assign a smaller array
11923 * to the rslt pointer, so we will assign it to the begin char pointer
11924 * and then copy the value into the rslt pointer.
11926 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11927 rslt = (struct vs_str_st *)begin;
11929 rstr = &rslt->str[0];
11930 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11931 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11932 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11933 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11935 Newx(vmsspec, VMS_MAXRSS, char);
11937 /* We could find out if there's an explicit dev/dir or version
11938 by peeking into lib$find_file's internal context at
11939 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11940 but that's unsupported, so I don't want to do it now and
11941 have it bite someone in the future. */
11942 /* Fix-me: vms_split_path() is the only way to do this, the
11943 existing method will fail with many legal EFS or UNIX specifications
11946 cp = SvPV(tmpglob,i);
11949 if (cp[i] == ';') hasver = 1;
11950 if (cp[i] == '.') {
11951 if (sts) hasver = 1;
11954 if (cp[i] == '/') {
11955 hasdir = isunix = 1;
11958 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11963 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11967 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11968 if (!stat_sts && S_ISDIR(st.st_mode)) {
11969 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11970 ok = (wilddsc.dsc$a_pointer != NULL);
11971 /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
11975 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11976 ok = (wilddsc.dsc$a_pointer != NULL);
11979 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11981 /* If not extended character set, replace ? with % */
11982 /* With extended character set, ? is a wildcard single character */
11983 if (!decc_efs_case_preserve) {
11984 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11985 if (*cp == '?') *cp = '%';
11988 while (ok && $VMS_STATUS_SUCCESS(sts)) {
11989 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11990 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11992 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11993 &dfltdsc,NULL,&rms_sts,&lff_flags);
11994 if (!$VMS_STATUS_SUCCESS(sts))
11999 /* with varying string, 1st word of buffer contains result length */
12000 rstr[rslt->length] = '\0';
12002 /* Find where all the components are */
12003 v_sts = vms_split_path
12018 /* If no version on input, truncate the version on output */
12019 if (!hasver && (vs_len > 0)) {
12023 /* No version & a null extension on UNIX handling */
12024 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12030 if (!decc_efs_case_preserve) {
12031 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12035 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12039 /* Start with the name */
12042 strcat(begin,"\n");
12043 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12045 if (cxt) (void)lib$find_file_end(&cxt);
12048 /* Be POSIXish: return the input pattern when no matches */
12049 begin = SvPVX(tmpglob);
12050 strcat(begin,"\n");
12051 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12054 if (ok && sts != RMS$_NMF &&
12055 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12058 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12060 PerlIO_close(tmpfp);
12064 PerlIO_rewind(tmpfp);
12065 IoTYPE(io) = IoTYPE_RDONLY;
12066 IoIFP(io) = fp = tmpfp;
12067 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
12078 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
12081 vms_realpath_fromperl(pTHX_ CV *cv)
12084 char *fspec, *rslt_spec, *rslt;
12087 if (!items || items != 1)
12088 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12090 fspec = SvPV(ST(0),n_a);
12091 if (!fspec || !*fspec) XSRETURN_UNDEF;
12093 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12094 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12095 ST(0) = sv_newmortal();
12097 sv_usepvn(ST(0),rslt,strlen(rslt));
12099 Safefree(rslt_spec);
12104 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12105 int do_vms_case_tolerant(void);
12108 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12111 ST(0) = boolSV(do_vms_case_tolerant());
12117 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12118 struct interp_intern *dst)
12120 memcpy(dst,src,sizeof(struct interp_intern));
12124 Perl_sys_intern_clear(pTHX)
12129 Perl_sys_intern_init(pTHX)
12131 unsigned int ix = RAND_MAX;
12136 /* fix me later to track running under GNV */
12137 /* this allows some limited testing */
12138 MY_POSIX_EXIT = decc_filename_unix_report;
12141 MY_INV_RAND_MAX = 1./x;
12145 init_os_extras(void)
12148 char* file = __FILE__;
12149 if (decc_disable_to_vms_logname_translation) {
12150 no_translate_barewords = TRUE;
12152 no_translate_barewords = FALSE;
12155 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12156 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12157 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12158 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12159 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12160 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12161 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12162 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12163 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12164 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12165 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12167 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12169 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12170 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12173 store_pipelocs(aTHX); /* will redo any earlier attempts */
12180 #if __CRTL_VER == 80200000
12181 /* This missed getting in to the DECC SDK for 8.2 */
12182 char *realpath(const char *file_name, char * resolved_name, ...);
12185 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12186 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12187 * The perl fallback routine to provide realpath() is not as efficient
12191 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12193 return realpath(filespec, outbuf);
12197 /* External entry points */
12198 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12199 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12201 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12206 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12207 /* case_tolerant */
12209 /*{{{int do_vms_case_tolerant(void)*/
12210 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12211 * controlled by a process setting.
12213 int do_vms_case_tolerant(void)
12215 return vms_process_case_tolerant;
12218 /* External entry points */
12219 int Perl_vms_case_tolerant(void)
12220 { return do_vms_case_tolerant(); }
12222 int Perl_vms_case_tolerant(void)
12223 { return vms_process_case_tolerant; }
12227 /* Start of DECC RTL Feature handling */
12229 static int sys_trnlnm
12230 (const char * logname,
12234 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12235 const unsigned long attr = LNM$M_CASE_BLIND;
12236 struct dsc$descriptor_s name_dsc;
12238 unsigned short result;
12239 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12242 name_dsc.dsc$w_length = strlen(logname);
12243 name_dsc.dsc$a_pointer = (char *)logname;
12244 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12245 name_dsc.dsc$b_class = DSC$K_CLASS_S;
12247 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12249 if ($VMS_STATUS_SUCCESS(status)) {
12251 /* Null terminate and return the string */
12252 /*--------------------------------------*/
12259 static int sys_crelnm
12260 (const char * logname,
12261 const char * value)
12264 const char * proc_table = "LNM$PROCESS_TABLE";
12265 struct dsc$descriptor_s proc_table_dsc;
12266 struct dsc$descriptor_s logname_dsc;
12267 struct itmlst_3 item_list[2];
12269 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12270 proc_table_dsc.dsc$w_length = strlen(proc_table);
12271 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12272 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12274 logname_dsc.dsc$a_pointer = (char *) logname;
12275 logname_dsc.dsc$w_length = strlen(logname);
12276 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12277 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12279 item_list[0].buflen = strlen(value);
12280 item_list[0].itmcode = LNM$_STRING;
12281 item_list[0].bufadr = (char *)value;
12282 item_list[0].retlen = NULL;
12284 item_list[1].buflen = 0;
12285 item_list[1].itmcode = 0;
12287 ret_val = sys$crelnm
12289 (const struct dsc$descriptor_s *)&proc_table_dsc,
12290 (const struct dsc$descriptor_s *)&logname_dsc,
12292 (const struct item_list_3 *) item_list);
12297 /* C RTL Feature settings */
12299 static int set_features
12300 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
12301 int (* cli_routine)(void), /* Not documented */
12302 void *image_info) /* Not documented */
12309 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12310 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12311 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12312 unsigned long case_perm;
12313 unsigned long case_image;
12316 /* Allow an exception to bring Perl into the VMS debugger */
12317 vms_debug_on_exception = 0;
12318 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12319 if ($VMS_STATUS_SUCCESS(status)) {
12320 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12321 vms_debug_on_exception = 1;
12323 vms_debug_on_exception = 0;
12326 /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12327 vms_vtf7_filenames = 0;
12328 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12329 if ($VMS_STATUS_SUCCESS(status)) {
12330 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12331 vms_vtf7_filenames = 1;
12333 vms_vtf7_filenames = 0;
12336 /* Dectect running under GNV Bash or other UNIX like shell */
12337 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12338 gnv_unix_shell = 0;
12339 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12340 if ($VMS_STATUS_SUCCESS(status)) {
12341 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12342 gnv_unix_shell = 1;
12343 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12344 set_feature_default("DECC$EFS_CHARSET", 1);
12345 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12346 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12347 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12348 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12351 gnv_unix_shell = 0;
12355 /* hacks to see if known bugs are still present for testing */
12357 /* Readdir is returning filenames in VMS syntax always */
12358 decc_bug_readdir_efs1 = 1;
12359 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12360 if ($VMS_STATUS_SUCCESS(status)) {
12361 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12362 decc_bug_readdir_efs1 = 1;
12364 decc_bug_readdir_efs1 = 0;
12367 /* PCP mode requires creating /dev/null special device file */
12368 decc_bug_devnull = 0;
12369 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12370 if ($VMS_STATUS_SUCCESS(status)) {
12371 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12372 decc_bug_devnull = 1;
12374 decc_bug_devnull = 0;
12377 /* fgetname returning a VMS name in UNIX mode */
12378 decc_bug_fgetname = 1;
12379 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12380 if ($VMS_STATUS_SUCCESS(status)) {
12381 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12382 decc_bug_fgetname = 1;
12384 decc_bug_fgetname = 0;
12387 /* UNIX directory names with no paths are broken in a lot of places */
12388 decc_dir_barename = 1;
12389 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12390 if ($VMS_STATUS_SUCCESS(status)) {
12391 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12392 decc_dir_barename = 1;
12394 decc_dir_barename = 0;
12397 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12398 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12400 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12401 if (decc_disable_to_vms_logname_translation < 0)
12402 decc_disable_to_vms_logname_translation = 0;
12405 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12407 decc_efs_case_preserve = decc$feature_get_value(s, 1);
12408 if (decc_efs_case_preserve < 0)
12409 decc_efs_case_preserve = 0;
12412 s = decc$feature_get_index("DECC$EFS_CHARSET");
12414 decc_efs_charset = decc$feature_get_value(s, 1);
12415 if (decc_efs_charset < 0)
12416 decc_efs_charset = 0;
12419 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12421 decc_filename_unix_report = decc$feature_get_value(s, 1);
12422 if (decc_filename_unix_report > 0)
12423 decc_filename_unix_report = 1;
12425 decc_filename_unix_report = 0;
12428 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12430 decc_filename_unix_only = decc$feature_get_value(s, 1);
12431 if (decc_filename_unix_only > 0) {
12432 decc_filename_unix_only = 1;
12435 decc_filename_unix_only = 0;
12439 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12441 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12442 if (decc_filename_unix_no_version < 0)
12443 decc_filename_unix_no_version = 0;
12446 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12448 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12449 if (decc_readdir_dropdotnotype < 0)
12450 decc_readdir_dropdotnotype = 0;
12453 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12454 if ($VMS_STATUS_SUCCESS(status)) {
12455 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12457 dflt = decc$feature_get_value(s, 4);
12459 decc_disable_posix_root = decc$feature_get_value(s, 1);
12460 if (decc_disable_posix_root <= 0) {
12461 decc$feature_set_value(s, 1, 1);
12462 decc_disable_posix_root = 1;
12466 /* Traditionally Perl assumes this is off */
12467 decc_disable_posix_root = 1;
12468 decc$feature_set_value(s, 1, 1);
12473 #if __CRTL_VER >= 80200000
12474 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12476 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12477 if (decc_posix_compliant_pathnames < 0)
12478 decc_posix_compliant_pathnames = 0;
12479 if (decc_posix_compliant_pathnames > 4)
12480 decc_posix_compliant_pathnames = 0;
12485 status = sys_trnlnm
12486 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12487 if ($VMS_STATUS_SUCCESS(status)) {
12488 val_str[0] = _toupper(val_str[0]);
12489 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12490 decc_disable_to_vms_logname_translation = 1;
12495 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12496 if ($VMS_STATUS_SUCCESS(status)) {
12497 val_str[0] = _toupper(val_str[0]);
12498 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12499 decc_efs_case_preserve = 1;
12504 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12505 if ($VMS_STATUS_SUCCESS(status)) {
12506 val_str[0] = _toupper(val_str[0]);
12507 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12508 decc_filename_unix_report = 1;
12511 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12512 if ($VMS_STATUS_SUCCESS(status)) {
12513 val_str[0] = _toupper(val_str[0]);
12514 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12515 decc_filename_unix_only = 1;
12516 decc_filename_unix_report = 1;
12519 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12520 if ($VMS_STATUS_SUCCESS(status)) {
12521 val_str[0] = _toupper(val_str[0]);
12522 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12523 decc_filename_unix_no_version = 1;
12526 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12527 if ($VMS_STATUS_SUCCESS(status)) {
12528 val_str[0] = _toupper(val_str[0]);
12529 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12530 decc_readdir_dropdotnotype = 1;
12535 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12537 /* Report true case tolerance */
12538 /*----------------------------*/
12539 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12540 if (!$VMS_STATUS_SUCCESS(status))
12541 case_perm = PPROP$K_CASE_BLIND;
12542 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12543 if (!$VMS_STATUS_SUCCESS(status))
12544 case_image = PPROP$K_CASE_BLIND;
12545 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12546 (case_image == PPROP$K_CASE_SENSITIVE))
12547 vms_process_case_tolerant = 0;
12552 /* CRTL can be initialized past this point, but not before. */
12553 /* DECC$CRTL_INIT(); */
12560 #pragma extern_model save
12561 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12562 const __align (LONGWORD) int spare[8] = {0};
12564 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
12565 #if __DECC_VER >= 60560002
12566 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
12568 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
12570 #endif /* __DECC */
12572 const long vms_cc_features = (const long)set_features;
12575 ** Force a reference to LIB$INITIALIZE to ensure it
12576 ** exists in the image.
12578 int lib$initialize(void);
12580 #pragma extern_model strict_refdef
12582 int lib_init_ref = (int) lib$initialize;
12585 #pragma extern_model restore