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>
29 #include <libclidef.h>
31 #include <lib$routines.h>
34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
44 #include <str$routines.h>
50 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
52 #define NO_EFN EFN$C_ENF
57 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
58 int decc$feature_get_index(const char *name);
59 char* decc$feature_get_name(int index);
60 int decc$feature_get_value(int index, int mode);
61 int decc$feature_set_value(int index, int mode, int value);
66 #pragma member_alignment save
67 #pragma nomember_alignment longword
72 unsigned short * retadr;
74 #pragma member_alignment restore
76 /* More specific prototype than in starlet_c.h makes programming errors
85 const struct dsc$descriptor_s * devnam,
86 const struct item_list_3 * itmlst,
88 void * (astadr)(unsigned long),
92 #if __CRTL_VER >= 70300000 && !defined(__VAX)
94 static int set_feature_default(const char *name, int value)
99 index = decc$feature_get_index(name);
101 status = decc$feature_set_value(index, 1, value);
102 if (index == -1 || (status == -1)) {
106 status = decc$feature_get_value(index, 1);
107 if (status != value) {
115 /* Older versions of ssdef.h don't have these */
116 #ifndef SS$_INVFILFOROP
117 # define SS$_INVFILFOROP 3930
119 #ifndef SS$_NOSUCHOBJECT
120 # define SS$_NOSUCHOBJECT 2696
123 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
124 #define PERLIO_NOT_STDIO 0
126 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
127 * code below needs to get to the underlying CRTL routines. */
128 #define DONT_MASK_RTL_CALLS
132 /* Anticipating future expansion in lexical warnings . . . */
133 #ifndef WARN_INTERNAL
134 # define WARN_INTERNAL WARN_MISC
137 #ifdef VMS_LONGNAME_SUPPORT
138 #include <libfildef.h>
141 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
142 # define RTL_USES_UTC 1
146 /* gcc's header files don't #define direct access macros
147 * corresponding to VAXC's variant structs */
149 # define uic$v_format uic$r_uic_form.uic$v_format
150 # define uic$v_group uic$r_uic_form.uic$v_group
151 # define uic$v_member uic$r_uic_form.uic$v_member
152 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
153 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
154 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
155 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
158 #if defined(NEED_AN_H_ERRNO)
163 #pragma message disable pragma
164 #pragma member_alignment save
165 #pragma nomember_alignment longword
167 #pragma message disable misalgndmem
170 unsigned short int buflen;
171 unsigned short int itmcode;
173 unsigned short int *retlen;
176 struct filescan_itmlst_2 {
177 unsigned short length;
178 unsigned short itmcode;
183 unsigned short length;
188 #pragma message restore
189 #pragma member_alignment restore
192 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
193 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
194 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
195 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
196 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
197 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
198 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
199 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
200 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
201 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
202 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
204 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
205 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
206 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
207 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
209 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
210 #define PERL_LNM_MAX_ALLOWED_INDEX 127
212 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
213 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
216 #define PERL_LNM_MAX_ITER 10
218 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
219 #if __CRTL_VER >= 70302000 && !defined(__VAX)
220 #define MAX_DCL_SYMBOL (8192)
221 #define MAX_DCL_LINE_LENGTH (4096 - 4)
223 #define MAX_DCL_SYMBOL (1024)
224 #define MAX_DCL_LINE_LENGTH (1024 - 4)
227 static char *__mystrtolower(char *str)
229 if (str) for (; *str; ++str) *str= tolower(*str);
233 static struct dsc$descriptor_s fildevdsc =
234 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
235 static struct dsc$descriptor_s crtlenvdsc =
236 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
237 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
238 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
239 static struct dsc$descriptor_s **env_tables = defenv;
240 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
242 /* True if we shouldn't treat barewords as logicals during directory */
244 static int no_translate_barewords;
247 static int tz_updated = 1;
250 /* DECC Features that may need to affect how Perl interprets
251 * displays filename information
253 static int decc_disable_to_vms_logname_translation = 1;
254 static int decc_disable_posix_root = 1;
255 int decc_efs_case_preserve = 0;
256 static int decc_efs_charset = 0;
257 static int decc_filename_unix_no_version = 0;
258 static int decc_filename_unix_only = 0;
259 int decc_filename_unix_report = 0;
260 int decc_posix_compliant_pathnames = 0;
261 int decc_readdir_dropdotnotype = 0;
262 static int vms_process_case_tolerant = 1;
263 int vms_vtf7_filenames = 0;
264 int gnv_unix_shell = 0;
266 /* bug workarounds if needed */
267 int decc_bug_readdir_efs1 = 0;
268 int decc_bug_devnull = 1;
269 int decc_bug_fgetname = 0;
270 int decc_dir_barename = 0;
272 static int vms_debug_on_exception = 0;
274 /* Is this a UNIX file specification?
275 * No longer a simple check with EFS file specs
276 * For now, not a full check, but need to
277 * handle POSIX ^UP^ specifications
278 * Fixing to handle ^/ cases would require
279 * changes to many other conversion routines.
282 static int is_unix_filespec(const char *path)
288 if (strncmp(path,"\"^UP^",5) != 0) {
289 pch1 = strchr(path, '/');
294 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
295 if (decc_filename_unix_report || decc_filename_unix_only) {
296 if (strcmp(path,".") == 0)
304 /* This routine converts a UCS-2 character to be VTF-7 encoded.
307 static void ucs2_to_vtf7
309 unsigned long ucs2_char,
312 unsigned char * ucs_ptr;
315 ucs_ptr = (unsigned char *)&ucs2_char;
319 hex = (ucs_ptr[1] >> 4) & 0xf;
321 outspec[2] = hex + '0';
323 outspec[2] = (hex - 9) + 'A';
324 hex = ucs_ptr[1] & 0xF;
326 outspec[3] = hex + '0';
328 outspec[3] = (hex - 9) + 'A';
330 hex = (ucs_ptr[0] >> 4) & 0xf;
332 outspec[4] = hex + '0';
334 outspec[4] = (hex - 9) + 'A';
335 hex = ucs_ptr[1] & 0xF;
337 outspec[5] = hex + '0';
339 outspec[5] = (hex - 9) + 'A';
345 /* This handles the conversion of a UNIX extended character set to a ^
346 * escaped VMS character.
347 * in a UNIX file specification.
349 * The output count variable contains the number of characters added
350 * to the output string.
352 * The return value is the number of characters read from the input string
354 static int copy_expand_unix_filename_escape
355 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
363 utf8_flag = *utf8_fl;
367 if (*inspec >= 0x80) {
368 if (utf8_fl && vms_vtf7_filenames) {
369 unsigned long ucs_char;
373 if ((*inspec & 0xE0) == 0xC0) {
375 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
376 if (ucs_char >= 0x80) {
377 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
380 } else if ((*inspec & 0xF0) == 0xE0) {
382 ucs_char = ((inspec[0] & 0xF) << 12) +
383 ((inspec[1] & 0x3f) << 6) +
385 if (ucs_char >= 0x800) {
386 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
390 #if 0 /* I do not see longer sequences supported by OpenVMS */
391 /* Maybe some one can fix this later */
392 } else if ((*inspec & 0xF8) == 0xF0) {
395 } else if ((*inspec & 0xFC) == 0xF8) {
398 } else if ((*inspec & 0xFE) == 0xFC) {
405 /* High bit set, but not a unicode character! */
407 /* Non printing DECMCS or ISO Latin-1 character? */
408 if (*inspec <= 0x9F) {
412 hex = (*inspec >> 4) & 0xF;
414 outspec[1] = hex + '0';
416 outspec[1] = (hex - 9) + 'A';
420 outspec[2] = hex + '0';
422 outspec[2] = (hex - 9) + 'A';
426 } else if (*inspec == 0xA0) {
432 } else if (*inspec == 0xFF) {
444 /* Is this a macro that needs to be passed through?
445 * Macros start with $( and an alpha character, followed
446 * by a string of alpha numeric characters ending with a )
447 * If this does not match, then encode it as ODS-5.
449 if ((inspec[0] == '$') && (inspec[1] == '(')) {
452 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
454 outspec[0] = inspec[0];
455 outspec[1] = inspec[1];
456 outspec[2] = inspec[2];
458 while(isalnum(inspec[tcnt]) ||
459 (inspec[2] == '.') || (inspec[2] == '_')) {
460 outspec[tcnt] = inspec[tcnt];
463 if (inspec[tcnt] == ')') {
464 outspec[tcnt] = inspec[tcnt];
481 if (decc_efs_charset == 0)
508 /* Assume that this is to be escaped */
510 outspec[1] = *inspec;
514 case ' ': /* space */
515 /* Assume that this is to be escaped */
530 /* This handles the expansion of a '^' prefix to the proper character
531 * in a UNIX file specification.
533 * The output count variable contains the number of characters added
534 * to the output string.
536 * The return value is the number of characters read from the input
539 static int copy_expand_vms_filename_escape
540 (char *outspec, const char *inspec, int *output_cnt)
547 if (*inspec == '^') {
551 /* Non trailing dots should just be passed through */
556 case '_': /* space */
562 case 'U': /* Unicode - FIX-ME this is wrong. */
565 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
568 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
569 outspec[0] == c1 & 0xff;
570 outspec[1] == c2 & 0xff;
577 /* Error - do best we can to continue */
587 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
591 scnt = sscanf(inspec, "%2x", &c1);
592 outspec[0] = c1 & 0xff;
615 (const struct dsc$descriptor_s * srcstr,
616 struct filescan_itmlst_2 * valuelist,
617 unsigned long * fldflags,
618 struct dsc$descriptor_s *auxout,
619 unsigned short * retlen);
621 /* vms_split_path - Verify that the input file specification is a
622 * VMS format file specification, and provide pointers to the components of
623 * it. With EFS format filenames, this is virtually the only way to
624 * parse a VMS path specification into components.
626 * If the sum of the components do not add up to the length of the
627 * string, then the passed file specification is probably a UNIX style
630 static int vms_split_path
645 struct dsc$descriptor path_desc;
649 struct filescan_itmlst_2 item_list[9];
650 const int filespec = 0;
651 const int nodespec = 1;
652 const int devspec = 2;
653 const int rootspec = 3;
654 const int dirspec = 4;
655 const int namespec = 5;
656 const int typespec = 6;
657 const int verspec = 7;
659 /* Assume the worst for an easy exit */
674 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
675 path_desc.dsc$w_length = strlen(path);
676 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
677 path_desc.dsc$b_class = DSC$K_CLASS_S;
679 /* Get the total length, if it is shorter than the string passed
680 * then this was probably not a VMS formatted file specification
682 item_list[filespec].itmcode = FSCN$_FILESPEC;
683 item_list[filespec].length = 0;
684 item_list[filespec].component = NULL;
686 /* If the node is present, then it gets considered as part of the
687 * volume name to hopefully make things simple.
689 item_list[nodespec].itmcode = FSCN$_NODE;
690 item_list[nodespec].length = 0;
691 item_list[nodespec].component = NULL;
693 item_list[devspec].itmcode = FSCN$_DEVICE;
694 item_list[devspec].length = 0;
695 item_list[devspec].component = NULL;
697 /* root is a special case, adding it to either the directory or
698 * the device components will probalby complicate things for the
699 * callers of this routine, so leave it separate.
701 item_list[rootspec].itmcode = FSCN$_ROOT;
702 item_list[rootspec].length = 0;
703 item_list[rootspec].component = NULL;
705 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
706 item_list[dirspec].length = 0;
707 item_list[dirspec].component = NULL;
709 item_list[namespec].itmcode = FSCN$_NAME;
710 item_list[namespec].length = 0;
711 item_list[namespec].component = NULL;
713 item_list[typespec].itmcode = FSCN$_TYPE;
714 item_list[typespec].length = 0;
715 item_list[typespec].component = NULL;
717 item_list[verspec].itmcode = FSCN$_VERSION;
718 item_list[verspec].length = 0;
719 item_list[verspec].component = NULL;
721 item_list[8].itmcode = 0;
722 item_list[8].length = 0;
723 item_list[8].component = NULL;
725 status = SYS$FILESCAN
726 ((const struct dsc$descriptor_s *)&path_desc, item_list,
728 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
730 /* If we parsed it successfully these two lengths should be the same */
731 if (path_desc.dsc$w_length != item_list[filespec].length)
734 /* If we got here, then it is a VMS file specification */
737 /* set the volume name */
738 if (item_list[nodespec].length > 0) {
739 *volume = item_list[nodespec].component;
740 *vol_len = item_list[nodespec].length + item_list[devspec].length;
743 *volume = item_list[devspec].component;
744 *vol_len = item_list[devspec].length;
747 *root = item_list[rootspec].component;
748 *root_len = item_list[rootspec].length;
750 *dir = item_list[dirspec].component;
751 *dir_len = item_list[dirspec].length;
753 /* Now fun with versions and EFS file specifications
754 * The parser can not tell the difference when a "." is a version
755 * delimiter or a part of the file specification.
757 if ((decc_efs_charset) &&
758 (item_list[verspec].length > 0) &&
759 (item_list[verspec].component[0] == '.')) {
760 *name = item_list[namespec].component;
761 *name_len = item_list[namespec].length + item_list[typespec].length;
762 *ext = item_list[verspec].component;
763 *ext_len = item_list[verspec].length;
768 *name = item_list[namespec].component;
769 *name_len = item_list[namespec].length;
770 *ext = item_list[typespec].component;
771 *ext_len = item_list[typespec].length;
772 *version = item_list[verspec].component;
773 *ver_len = item_list[verspec].length;
780 * Routine to retrieve the maximum equivalence index for an input
781 * logical name. Some calls to this routine have no knowledge if
782 * the variable is a logical or not. So on error we return a max
785 /*{{{int my_maxidx(const char *lnm) */
787 my_maxidx(const char *lnm)
791 int attr = LNM$M_CASE_BLIND;
792 struct dsc$descriptor lnmdsc;
793 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
796 lnmdsc.dsc$w_length = strlen(lnm);
797 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
798 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
799 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
801 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
802 if ((status & 1) == 0)
809 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
811 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
812 struct dsc$descriptor_s **tabvec, unsigned long int flags)
815 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
816 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
817 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
819 unsigned char acmode;
820 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
821 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
822 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
823 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
825 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
826 #if defined(PERL_IMPLICIT_CONTEXT)
829 aTHX = PERL_GET_INTERP;
835 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
836 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
838 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
839 *cp2 = _toupper(*cp1);
840 if (cp1 - lnm > LNM$C_NAMLENGTH) {
841 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
845 lnmdsc.dsc$w_length = cp1 - lnm;
846 lnmdsc.dsc$a_pointer = uplnm;
847 uplnm[lnmdsc.dsc$w_length] = '\0';
848 secure = flags & PERL__TRNENV_SECURE;
849 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
850 if (!tabvec || !*tabvec) tabvec = env_tables;
852 for (curtab = 0; tabvec[curtab]; curtab++) {
853 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
854 if (!ivenv && !secure) {
859 Perl_warn(aTHX_ "Can't read CRTL environ\n");
862 retsts = SS$_NOLOGNAM;
863 for (i = 0; environ[i]; i++) {
864 if ((eq = strchr(environ[i],'=')) &&
865 lnmdsc.dsc$w_length == (eq - environ[i]) &&
866 !strncmp(environ[i],uplnm,eq - environ[i])) {
868 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
869 if (!eqvlen) continue;
874 if (retsts != SS$_NOLOGNAM) break;
877 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
878 !str$case_blind_compare(&tmpdsc,&clisym)) {
879 if (!ivsym && !secure) {
880 unsigned short int deflen = LNM$C_NAMLENGTH;
881 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
882 /* dynamic dsc to accomodate possible long value */
883 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
884 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
886 if (eqvlen > MAX_DCL_SYMBOL) {
887 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
888 eqvlen = MAX_DCL_SYMBOL;
889 /* Special hack--we might be called before the interpreter's */
890 /* fully initialized, in which case either thr or PL_curcop */
891 /* might be bogus. We have to check, since ckWARN needs them */
892 /* both to be valid if running threaded */
893 if (ckWARN(WARN_MISC)) {
894 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
897 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
899 _ckvmssts(lib$sfree1_dd(&eqvdsc));
900 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
901 if (retsts == LIB$_NOSUCHSYM) continue;
906 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
907 midx = my_maxidx(lnm);
908 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
909 lnmlst[1].bufadr = cp2;
911 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
912 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
913 if (retsts == SS$_NOLOGNAM) break;
914 /* PPFs have a prefix */
917 *((int *)uplnm) == *((int *)"SYS$") &&
919 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
920 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
921 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
922 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
923 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
924 memmove(eqv,eqv+4,eqvlen-4);
930 if ((retsts == SS$_IVLOGNAM) ||
931 (retsts == SS$_NOLOGNAM)) { continue; }
934 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
935 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
936 if (retsts == SS$_NOLOGNAM) continue;
939 eqvlen = strlen(eqv);
943 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
944 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
945 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
946 retsts == SS$_NOLOGNAM) {
947 set_errno(EINVAL); set_vaxc_errno(retsts);
949 else _ckvmssts(retsts);
951 } /* end of vmstrnenv */
954 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
955 /* Define as a function so we can access statics. */
956 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
958 return vmstrnenv(lnm,eqv,idx,fildev,
959 #ifdef SECURE_INTERNAL_GETENV
960 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
969 * Note: Uses Perl temp to store result so char * can be returned to
970 * caller; this pointer will be invalidated at next Perl statement
972 * We define this as a function rather than a macro in terms of my_getenv_len()
973 * so that it'll work when PL_curinterp is undefined (and we therefore can't
976 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
978 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
981 static char *__my_getenv_eqv = NULL;
982 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
983 unsigned long int idx = 0;
984 int trnsuccess, success, secure, saverr, savvmserr;
988 midx = my_maxidx(lnm) + 1;
990 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
991 /* Set up a temporary buffer for the return value; Perl will
992 * clean it up at the next statement transition */
993 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
994 if (!tmpsv) return NULL;
998 /* Assume no interpreter ==> single thread */
999 if (__my_getenv_eqv != NULL) {
1000 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1003 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1005 eqv = __my_getenv_eqv;
1008 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1009 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1011 getcwd(eqv,LNM$C_NAMLENGTH);
1015 /* Get rid of "000000/ in rooted filespecs */
1018 zeros = strstr(eqv, "/000000/");
1019 if (zeros != NULL) {
1021 mlen = len - (zeros - eqv) - 7;
1022 memmove(zeros, &zeros[7], mlen);
1030 /* Impose security constraints only if tainting */
1032 /* Impose security constraints only if tainting */
1033 secure = PL_curinterp ? PL_tainting : will_taint;
1034 saverr = errno; savvmserr = vaxc$errno;
1041 #ifdef SECURE_INTERNAL_GETENV
1042 secure ? PERL__TRNENV_SECURE : 0
1048 /* For the getenv interface we combine all the equivalence names
1049 * of a search list logical into one value to acquire a maximum
1050 * value length of 255*128 (assuming %ENV is using logicals).
1052 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1054 /* If the name contains a semicolon-delimited index, parse it
1055 * off and make sure we only retrieve the equivalence name for
1057 if ((cp2 = strchr(lnm,';')) != NULL) {
1059 uplnm[cp2-lnm] = '\0';
1060 idx = strtoul(cp2+1,NULL,0);
1062 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1065 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1067 /* Discard NOLOGNAM on internal calls since we're often looking
1068 * for an optional name, and this "error" often shows up as the
1069 * (bogus) exit status for a die() call later on. */
1070 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1071 return success ? eqv : Nullch;
1074 } /* end of my_getenv() */
1078 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1080 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1084 unsigned long idx = 0;
1086 static char *__my_getenv_len_eqv = NULL;
1087 int secure, saverr, savvmserr;
1090 midx = my_maxidx(lnm) + 1;
1092 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1093 /* Set up a temporary buffer for the return value; Perl will
1094 * clean it up at the next statement transition */
1095 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1096 if (!tmpsv) return NULL;
1100 /* Assume no interpreter ==> single thread */
1101 if (__my_getenv_len_eqv != NULL) {
1102 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1105 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1107 buf = __my_getenv_len_eqv;
1110 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1111 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1114 getcwd(buf,LNM$C_NAMLENGTH);
1117 /* Get rid of "000000/ in rooted filespecs */
1119 zeros = strstr(buf, "/000000/");
1120 if (zeros != NULL) {
1122 mlen = *len - (zeros - buf) - 7;
1123 memmove(zeros, &zeros[7], mlen);
1132 /* Impose security constraints only if tainting */
1133 secure = PL_curinterp ? PL_tainting : will_taint;
1134 saverr = errno; savvmserr = vaxc$errno;
1141 #ifdef SECURE_INTERNAL_GETENV
1142 secure ? PERL__TRNENV_SECURE : 0
1148 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1150 if ((cp2 = strchr(lnm,';')) != NULL) {
1152 buf[cp2-lnm] = '\0';
1153 idx = strtoul(cp2+1,NULL,0);
1155 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1158 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1160 /* Get rid of "000000/ in rooted filespecs */
1163 zeros = strstr(buf, "/000000/");
1164 if (zeros != NULL) {
1166 mlen = *len - (zeros - buf) - 7;
1167 memmove(zeros, &zeros[7], mlen);
1173 /* Discard NOLOGNAM on internal calls since we're often looking
1174 * for an optional name, and this "error" often shows up as the
1175 * (bogus) exit status for a die() call later on. */
1176 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1177 return *len ? buf : Nullch;
1180 } /* end of my_getenv_len() */
1183 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1185 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1187 /*{{{ void prime_env_iter() */
1189 prime_env_iter(void)
1190 /* Fill the %ENV associative array with all logical names we can
1191 * find, in preparation for iterating over it.
1194 static int primed = 0;
1195 HV *seenhv = NULL, *envhv;
1197 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1198 unsigned short int chan;
1199 #ifndef CLI$M_TRUSTED
1200 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1202 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1203 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1205 bool have_sym = FALSE, have_lnm = FALSE;
1206 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1207 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1208 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1209 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1210 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1211 #if defined(PERL_IMPLICIT_CONTEXT)
1214 #if defined(USE_ITHREADS)
1215 static perl_mutex primenv_mutex;
1216 MUTEX_INIT(&primenv_mutex);
1219 #if defined(PERL_IMPLICIT_CONTEXT)
1220 /* We jump through these hoops because we can be called at */
1221 /* platform-specific initialization time, which is before anything is */
1222 /* set up--we can't even do a plain dTHX since that relies on the */
1223 /* interpreter structure to be initialized */
1225 aTHX = PERL_GET_INTERP;
1231 if (primed || !PL_envgv) return;
1232 MUTEX_LOCK(&primenv_mutex);
1233 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1234 envhv = GvHVn(PL_envgv);
1235 /* Perform a dummy fetch as an lval to insure that the hash table is
1236 * set up. Otherwise, the hv_store() will turn into a nullop. */
1237 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1239 for (i = 0; env_tables[i]; i++) {
1240 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1241 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1242 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1244 if (have_sym || have_lnm) {
1245 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1246 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1247 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1248 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1251 for (i--; i >= 0; i--) {
1252 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1255 for (j = 0; environ[j]; j++) {
1256 if (!(start = strchr(environ[j],'='))) {
1257 if (ckWARN(WARN_INTERNAL))
1258 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1262 sv = newSVpv(start,0);
1264 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1269 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1270 !str$case_blind_compare(&tmpdsc,&clisym)) {
1271 strcpy(cmd,"Show Symbol/Global *");
1272 cmddsc.dsc$w_length = 20;
1273 if (env_tables[i]->dsc$w_length == 12 &&
1274 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1275 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1276 flags = defflags | CLI$M_NOLOGNAM;
1279 strcpy(cmd,"Show Logical *");
1280 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1281 strcat(cmd," /Table=");
1282 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1283 cmddsc.dsc$w_length = strlen(cmd);
1285 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1286 flags = defflags | CLI$M_NOCLISYM;
1289 /* Create a new subprocess to execute each command, to exclude the
1290 * remote possibility that someone could subvert a mbx or file used
1291 * to write multiple commands to a single subprocess.
1294 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1295 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1296 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1297 defflags &= ~CLI$M_TRUSTED;
1298 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1300 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1301 if (seenhv) SvREFCNT_dec(seenhv);
1304 char *cp1, *cp2, *key;
1305 unsigned long int sts, iosb[2], retlen, keylen;
1308 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1309 if (sts & 1) sts = iosb[0] & 0xffff;
1310 if (sts == SS$_ENDOFFILE) {
1312 while (substs == 0) { sys$hiber(); wakect++;}
1313 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1318 retlen = iosb[0] >> 16;
1319 if (!retlen) continue; /* blank line */
1321 if (iosb[1] != subpid) {
1323 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1327 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1328 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1330 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1331 if (*cp1 == '(' || /* Logical name table name */
1332 *cp1 == '=' /* Next eqv of searchlist */) continue;
1333 if (*cp1 == '"') cp1++;
1334 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1335 key = cp1; keylen = cp2 - cp1;
1336 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1337 while (*cp2 && *cp2 != '=') cp2++;
1338 while (*cp2 && *cp2 == '=') cp2++;
1339 while (*cp2 && *cp2 == ' ') cp2++;
1340 if (*cp2 == '"') { /* String translation; may embed "" */
1341 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1342 cp2++; cp1--; /* Skip "" surrounding translation */
1344 else { /* Numeric translation */
1345 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1346 cp1--; /* stop on last non-space char */
1348 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1349 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1352 PERL_HASH(hash,key,keylen);
1354 if (cp1 == cp2 && *cp2 == '.') {
1355 /* A single dot usually means an unprintable character, such as a null
1356 * to indicate a zero-length value. Get the actual value to make sure.
1358 char lnm[LNM$C_NAMLENGTH+1];
1359 char eqv[MAX_DCL_SYMBOL+1];
1360 strncpy(lnm, key, keylen);
1361 int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1362 sv = newSVpvn(eqv, strlen(eqv));
1365 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1369 hv_store(envhv,key,keylen,sv,hash);
1370 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1372 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1373 /* get the PPFs for this process, not the subprocess */
1374 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1375 char eqv[LNM$C_NAMLENGTH+1];
1377 for (i = 0; ppfs[i]; i++) {
1378 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1379 sv = newSVpv(eqv,trnlen);
1381 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1386 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1387 if (buf) Safefree(buf);
1388 if (seenhv) SvREFCNT_dec(seenhv);
1389 MUTEX_UNLOCK(&primenv_mutex);
1392 } /* end of prime_env_iter */
1396 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1397 /* Define or delete an element in the same "environment" as
1398 * vmstrnenv(). If an element is to be deleted, it's removed from
1399 * the first place it's found. If it's to be set, it's set in the
1400 * place designated by the first element of the table vector.
1401 * Like setenv() returns 0 for success, non-zero on error.
1404 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1407 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1408 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1410 unsigned long int retsts, usermode = PSL$C_USER;
1411 struct itmlst_3 *ile, *ilist;
1412 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1413 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1414 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1415 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1416 $DESCRIPTOR(local,"_LOCAL");
1419 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1420 return SS$_IVLOGNAM;
1423 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1424 *cp2 = _toupper(*cp1);
1425 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1426 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1427 return SS$_IVLOGNAM;
1430 lnmdsc.dsc$w_length = cp1 - lnm;
1431 if (!tabvec || !*tabvec) tabvec = env_tables;
1433 if (!eqv) { /* we're deleting n element */
1434 for (curtab = 0; tabvec[curtab]; curtab++) {
1435 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1437 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1438 if ((cp1 = strchr(environ[i],'=')) &&
1439 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1440 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1442 return setenv(lnm,"",1) ? vaxc$errno : 0;
1445 ivenv = 1; retsts = SS$_NOLOGNAM;
1447 if (ckWARN(WARN_INTERNAL))
1448 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1449 ivenv = 1; retsts = SS$_NOSUCHPGM;
1455 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1456 !str$case_blind_compare(&tmpdsc,&clisym)) {
1457 unsigned int symtype;
1458 if (tabvec[curtab]->dsc$w_length == 12 &&
1459 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1460 !str$case_blind_compare(&tmpdsc,&local))
1461 symtype = LIB$K_CLI_LOCAL_SYM;
1462 else symtype = LIB$K_CLI_GLOBAL_SYM;
1463 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1464 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1465 if (retsts == LIB$_NOSUCHSYM) continue;
1469 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1470 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1471 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1472 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1473 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1477 else { /* we're defining a value */
1478 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1480 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1482 if (ckWARN(WARN_INTERNAL))
1483 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1484 retsts = SS$_NOSUCHPGM;
1488 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1489 eqvdsc.dsc$w_length = strlen(eqv);
1490 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1491 !str$case_blind_compare(&tmpdsc,&clisym)) {
1492 unsigned int symtype;
1493 if (tabvec[0]->dsc$w_length == 12 &&
1494 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1495 !str$case_blind_compare(&tmpdsc,&local))
1496 symtype = LIB$K_CLI_LOCAL_SYM;
1497 else symtype = LIB$K_CLI_GLOBAL_SYM;
1498 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1501 if (!*eqv) eqvdsc.dsc$w_length = 1;
1502 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1504 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1505 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1506 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1507 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1508 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1509 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1512 Newx(ilist,nseg+1,struct itmlst_3);
1515 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1518 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1520 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1521 ile->itmcode = LNM$_STRING;
1523 if ((j+1) == nseg) {
1524 ile->buflen = strlen(c);
1525 /* in case we are truncating one that's too long */
1526 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1529 ile->buflen = LNM$C_NAMLENGTH;
1533 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1537 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1542 if (!(retsts & 1)) {
1544 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1545 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1546 set_errno(EVMSERR); break;
1547 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1548 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1549 set_errno(EINVAL); break;
1551 set_errno(EACCES); break;
1556 set_vaxc_errno(retsts);
1557 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1560 /* We reset error values on success because Perl does an hv_fetch()
1561 * before each hv_store(), and if the thing we're setting didn't
1562 * previously exist, we've got a leftover error message. (Of course,
1563 * this fails in the face of
1564 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1565 * in that the error reported in $! isn't spurious,
1566 * but it's right more often than not.)
1568 set_errno(0); set_vaxc_errno(retsts);
1572 } /* end of vmssetenv() */
1575 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1576 /* This has to be a function since there's a prototype for it in proto.h */
1578 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1581 int len = strlen(lnm);
1585 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1586 if (!strcmp(uplnm,"DEFAULT")) {
1587 if (eqv && *eqv) my_chdir(eqv);
1591 #ifndef RTL_USES_UTC
1592 if (len == 6 || len == 2) {
1595 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1597 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1598 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1602 (void) vmssetenv(lnm,eqv,NULL);
1606 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1608 * sets a user-mode logical in the process logical name table
1609 * used for redirection of sys$error
1612 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1614 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1615 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1616 unsigned long int iss, attr = LNM$M_CONFINE;
1617 unsigned char acmode = PSL$C_USER;
1618 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1620 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1621 d_name.dsc$w_length = strlen(name);
1623 lnmlst[0].buflen = strlen(eqv);
1624 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1626 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1627 if (!(iss&1)) lib$signal(iss);
1632 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1633 /* my_crypt - VMS password hashing
1634 * my_crypt() provides an interface compatible with the Unix crypt()
1635 * C library function, and uses sys$hash_password() to perform VMS
1636 * password hashing. The quadword hashed password value is returned
1637 * as a NUL-terminated 8 character string. my_crypt() does not change
1638 * the case of its string arguments; in order to match the behavior
1639 * of LOGINOUT et al., alphabetic characters in both arguments must
1640 * be upcased by the caller.
1642 * - fix me to call ACM services when available
1645 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1647 # ifndef UAI$C_PREFERRED_ALGORITHM
1648 # define UAI$C_PREFERRED_ALGORITHM 127
1650 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1651 unsigned short int salt = 0;
1652 unsigned long int sts;
1654 unsigned short int dsc$w_length;
1655 unsigned char dsc$b_type;
1656 unsigned char dsc$b_class;
1657 const char * dsc$a_pointer;
1658 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1659 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1660 struct itmlst_3 uailst[3] = {
1661 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1662 { sizeof salt, UAI$_SALT, &salt, 0},
1663 { 0, 0, NULL, NULL}};
1664 static char hash[9];
1666 usrdsc.dsc$w_length = strlen(usrname);
1667 usrdsc.dsc$a_pointer = usrname;
1668 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1670 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1674 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1679 set_vaxc_errno(sts);
1680 if (sts != RMS$_RNF) return NULL;
1683 txtdsc.dsc$w_length = strlen(textpasswd);
1684 txtdsc.dsc$a_pointer = textpasswd;
1685 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1686 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1689 return (char *) hash;
1691 } /* end of my_crypt() */
1695 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1696 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1697 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1699 /* fixup barenames that are directories for internal use.
1700 * There have been problems with the consistent handling of UNIX
1701 * style directory names when routines are presented with a name that
1702 * has no directory delimitors at all. So this routine will eventually
1705 static char * fixup_bare_dirnames(const char * name)
1707 if (decc_disable_to_vms_logname_translation) {
1714 * A little hack to get around a bug in some implemenation of remove()
1715 * that do not know how to delete a directory
1717 * Delete any file to which user has control access, regardless of whether
1718 * delete access is explicitly allowed.
1719 * Limitations: User must have write access to parent directory.
1720 * Does not block signals or ASTs; if interrupted in midstream
1721 * may leave file with an altered ACL.
1724 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1726 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1728 char *vmsname, *rspec;
1730 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1731 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1732 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1734 unsigned char myace$b_length;
1735 unsigned char myace$b_type;
1736 unsigned short int myace$w_flags;
1737 unsigned long int myace$l_access;
1738 unsigned long int myace$l_ident;
1739 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1740 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1741 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1743 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1744 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1745 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1746 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1747 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1748 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1750 /* Expand the input spec using RMS, since the CRTL remove() and
1751 * system services won't do this by themselves, so we may miss
1752 * a file "hiding" behind a logical name or search list. */
1753 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1754 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1756 if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1757 PerlMem_free(vmsname);
1761 if (decc_posix_compliant_pathnames) {
1762 /* In POSIX mode, we prefer to remove the UNIX name */
1764 remove_name = (char *)name;
1767 rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1768 if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1769 if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1770 PerlMem_free(rspec);
1771 PerlMem_free(vmsname);
1774 PerlMem_free(vmsname);
1775 remove_name = rspec;
1778 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1780 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1781 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1782 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1784 do_pathify_dirspec(name, remove_name, 0, NULL);
1785 if (!rmdir(remove_name)) {
1787 PerlMem_free(remove_name);
1788 PerlMem_free(rspec);
1789 return 0; /* Can we just get rid of it? */
1793 if (!rmdir(remove_name)) {
1794 PerlMem_free(rspec);
1795 return 0; /* Can we just get rid of it? */
1801 if (!remove(remove_name)) {
1802 PerlMem_free(rspec);
1803 return 0; /* Can we just get rid of it? */
1806 /* If not, can changing protections help? */
1807 if (vaxc$errno != RMS$_PRV) {
1808 PerlMem_free(rspec);
1812 /* No, so we get our own UIC to use as a rights identifier,
1813 * and the insert an ACE at the head of the ACL which allows us
1814 * to delete the file.
1816 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1817 fildsc.dsc$w_length = strlen(rspec);
1818 fildsc.dsc$a_pointer = rspec;
1820 newace.myace$l_ident = oldace.myace$l_ident;
1821 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1823 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1824 set_errno(ENOENT); break;
1826 set_errno(ENOTDIR); break;
1828 set_errno(ENODEV); break;
1829 case RMS$_SYN: case SS$_INVFILFOROP:
1830 set_errno(EINVAL); break;
1832 set_errno(EACCES); break;
1836 set_vaxc_errno(aclsts);
1837 PerlMem_free(rspec);
1840 /* Grab any existing ACEs with this identifier in case we fail */
1841 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1842 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1843 || fndsts == SS$_NOMOREACE ) {
1844 /* Add the new ACE . . . */
1845 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1848 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1850 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1851 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1852 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1854 do_pathify_dirspec(name, remove_name, 0, NULL);
1855 rmsts = rmdir(remove_name);
1856 PerlMem_free(remove_name);
1859 rmsts = rmdir(remove_name);
1863 rmsts = remove(remove_name);
1865 /* We blew it - dir with files in it, no write priv for
1866 * parent directory, etc. Put things back the way they were. */
1867 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1870 addlst[0].bufadr = &oldace;
1871 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1878 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1879 /* We just deleted it, so of course it's not there. Some versions of
1880 * VMS seem to return success on the unlock operation anyhow (after all
1881 * the unlock is successful), but others don't.
1883 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1884 if (aclsts & 1) aclsts = fndsts;
1885 if (!(aclsts & 1)) {
1887 set_vaxc_errno(aclsts);
1888 PerlMem_free(rspec);
1892 PerlMem_free(rspec);
1895 } /* end of kill_file() */
1899 /*{{{int do_rmdir(char *name)*/
1901 Perl_do_rmdir(pTHX_ const char *name)
1903 char dirfile[NAM$C_MAXRSS+1];
1907 if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1908 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1909 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1912 } /* end of do_rmdir */
1916 * Delete any file to which user has control access, regardless of whether
1917 * delete access is explicitly allowed.
1918 * Limitations: User must have write access to parent directory.
1919 * Does not block signals or ASTs; if interrupted in midstream
1920 * may leave file with an altered ACL.
1923 /*{{{int kill_file(char *name)*/
1925 Perl_kill_file(pTHX_ const char *name)
1927 char rspec[NAM$C_MAXRSS+1];
1929 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1930 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1931 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1933 unsigned char myace$b_length;
1934 unsigned char myace$b_type;
1935 unsigned short int myace$w_flags;
1936 unsigned long int myace$l_access;
1937 unsigned long int myace$l_ident;
1938 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1939 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1940 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1942 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1943 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1944 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1945 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1946 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1947 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1949 /* Expand the input spec using RMS, since the CRTL remove() and
1950 * system services won't do this by themselves, so we may miss
1951 * a file "hiding" behind a logical name or search list. */
1952 tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1953 if (tspec == NULL) return -1;
1954 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1955 /* If not, can changing protections help? */
1956 if (vaxc$errno != RMS$_PRV) return -1;
1958 /* No, so we get our own UIC to use as a rights identifier,
1959 * and the insert an ACE at the head of the ACL which allows us
1960 * to delete the file.
1962 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1963 fildsc.dsc$w_length = strlen(rspec);
1964 fildsc.dsc$a_pointer = rspec;
1966 newace.myace$l_ident = oldace.myace$l_ident;
1967 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1969 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1970 set_errno(ENOENT); break;
1972 set_errno(ENOTDIR); break;
1974 set_errno(ENODEV); break;
1975 case RMS$_SYN: case SS$_INVFILFOROP:
1976 set_errno(EINVAL); break;
1978 set_errno(EACCES); break;
1982 set_vaxc_errno(aclsts);
1985 /* Grab any existing ACEs with this identifier in case we fail */
1986 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1987 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1988 || fndsts == SS$_NOMOREACE ) {
1989 /* Add the new ACE . . . */
1990 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1992 if ((rmsts = remove(name))) {
1993 /* We blew it - dir with files in it, no write priv for
1994 * parent directory, etc. Put things back the way they were. */
1995 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1998 addlst[0].bufadr = &oldace;
1999 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2006 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2007 /* We just deleted it, so of course it's not there. Some versions of
2008 * VMS seem to return success on the unlock operation anyhow (after all
2009 * the unlock is successful), but others don't.
2011 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2012 if (aclsts & 1) aclsts = fndsts;
2013 if (!(aclsts & 1)) {
2015 set_vaxc_errno(aclsts);
2021 } /* end of kill_file() */
2025 /*{{{int my_mkdir(char *,Mode_t)*/
2027 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2029 STRLEN dirlen = strlen(dir);
2031 /* zero length string sometimes gives ACCVIO */
2032 if (dirlen == 0) return -1;
2034 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2035 * null file name/type. However, it's commonplace under Unix,
2036 * so we'll allow it for a gain in portability.
2038 if (dir[dirlen-1] == '/') {
2039 char *newdir = savepvn(dir,dirlen-1);
2040 int ret = mkdir(newdir,mode);
2044 else return mkdir(dir,mode);
2045 } /* end of my_mkdir */
2048 /*{{{int my_chdir(char *)*/
2050 Perl_my_chdir(pTHX_ const char *dir)
2052 STRLEN dirlen = strlen(dir);
2054 /* zero length string sometimes gives ACCVIO */
2055 if (dirlen == 0) return -1;
2058 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2059 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2060 * so that existing scripts do not need to be changed.
2063 while ((dirlen > 0) && (*dir1 == ' ')) {
2068 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2070 * null file name/type. However, it's commonplace under Unix,
2071 * so we'll allow it for a gain in portability.
2073 * - Preview- '/' will be valid soon on VMS
2075 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2076 char *newdir = savepvn(dir1,dirlen-1);
2077 int ret = chdir(newdir);
2081 else return chdir(dir1);
2082 } /* end of my_chdir */
2086 /*{{{FILE *my_tmpfile()*/
2093 if ((fp = tmpfile())) return fp;
2095 cp = PerlMem_malloc(L_tmpnam+24);
2096 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2098 if (decc_filename_unix_only == 0)
2099 strcpy(cp,"Sys$Scratch:");
2102 tmpnam(cp+strlen(cp));
2103 strcat(cp,".Perltmp");
2104 fp = fopen(cp,"w+","fop=dlt");
2111 #ifndef HOMEGROWN_POSIX_SIGNALS
2113 * The C RTL's sigaction fails to check for invalid signal numbers so we
2114 * help it out a bit. The docs are correct, but the actual routine doesn't
2115 * do what the docs say it will.
2117 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2119 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2120 struct sigaction* oact)
2122 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2123 SETERRNO(EINVAL, SS$_INVARG);
2126 return sigaction(sig, act, oact);
2131 #ifdef KILL_BY_SIGPRC
2132 #include <errnodef.h>
2134 /* We implement our own kill() using the undocumented system service
2135 sys$sigprc for one of two reasons:
2137 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2138 target process to do a sys$exit, which usually can't be handled
2139 gracefully...certainly not by Perl and the %SIG{} mechanism.
2141 2.) If the kill() in the CRTL can't be called from a signal
2142 handler without disappearing into the ether, i.e., the signal
2143 it purportedly sends is never trapped. Still true as of VMS 7.3.
2145 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2146 in the target process rather than calling sys$exit.
2148 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2149 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2150 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2151 with condition codes C$_SIG0+nsig*8, catching the exception on the
2152 target process and resignaling with appropriate arguments.
2154 But we don't have that VMS 7.0+ exception handler, so if you
2155 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2157 Also note that SIGTERM is listed in the docs as being "unimplemented",
2158 yet always seems to be signaled with a VMS condition code of 4 (and
2159 correctly handled for that code). So we hardwire it in.
2161 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2162 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2163 than signalling with an unrecognized (and unhandled by CRTL) code.
2166 #define _MY_SIG_MAX 17
2169 Perl_sig_to_vmscondition_int(int sig)
2171 static unsigned int sig_code[_MY_SIG_MAX+1] =
2174 SS$_HANGUP, /* 1 SIGHUP */
2175 SS$_CONTROLC, /* 2 SIGINT */
2176 SS$_CONTROLY, /* 3 SIGQUIT */
2177 SS$_RADRMOD, /* 4 SIGILL */
2178 SS$_BREAK, /* 5 SIGTRAP */
2179 SS$_OPCCUS, /* 6 SIGABRT */
2180 SS$_COMPAT, /* 7 SIGEMT */
2182 SS$_FLTOVF, /* 8 SIGFPE VAX */
2184 SS$_HPARITH, /* 8 SIGFPE AXP */
2186 SS$_ABORT, /* 9 SIGKILL */
2187 SS$_ACCVIO, /* 10 SIGBUS */
2188 SS$_ACCVIO, /* 11 SIGSEGV */
2189 SS$_BADPARAM, /* 12 SIGSYS */
2190 SS$_NOMBX, /* 13 SIGPIPE */
2191 SS$_ASTFLT, /* 14 SIGALRM */
2197 #if __VMS_VER >= 60200000
2198 static int initted = 0;
2201 sig_code[16] = C$_SIGUSR1;
2202 sig_code[17] = C$_SIGUSR2;
2206 if (sig < _SIG_MIN) return 0;
2207 if (sig > _MY_SIG_MAX) return 0;
2208 return sig_code[sig];
2212 Perl_sig_to_vmscondition(int sig)
2215 if (vms_debug_on_exception != 0)
2216 lib$signal(SS$_DEBUG);
2218 return Perl_sig_to_vmscondition_int(sig);
2223 Perl_my_kill(int pid, int sig)
2228 int sys$sigprc(unsigned int *pidadr,
2229 struct dsc$descriptor_s *prcname,
2232 /* sig 0 means validate the PID */
2233 /*------------------------------*/
2235 const unsigned long int jpicode = JPI$_PID;
2238 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2239 if ($VMS_STATUS_SUCCESS(status))
2242 case SS$_NOSUCHNODE:
2243 case SS$_UNREACHABLE:
2257 code = Perl_sig_to_vmscondition_int(sig);
2260 SETERRNO(EINVAL, SS$_BADPARAM);
2264 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2265 * signals are to be sent to multiple processes.
2266 * pid = 0 - all processes in group except ones that the system exempts
2267 * pid = -1 - all processes except ones that the system exempts
2268 * pid = -n - all processes in group (abs(n)) except ...
2269 * For now, just report as not supported.
2273 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2277 iss = sys$sigprc((unsigned int *)&pid,0,code);
2278 if (iss&1) return 0;
2282 set_errno(EPERM); break;
2284 case SS$_NOSUCHNODE:
2285 case SS$_UNREACHABLE:
2286 set_errno(ESRCH); break;
2288 set_errno(ENOMEM); break;
2293 set_vaxc_errno(iss);
2299 /* Routine to convert a VMS status code to a UNIX status code.
2300 ** More tricky than it appears because of conflicting conventions with
2303 ** VMS status codes are a bit mask, with the least significant bit set for
2306 ** Special UNIX status of EVMSERR indicates that no translation is currently
2307 ** available, and programs should check the VMS status code.
2309 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2313 #ifndef C_FACILITY_NO
2314 #define C_FACILITY_NO 0x350000
2317 #define DCL_IVVERB 0x38090
2320 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2328 /* Assume the best or the worst */
2329 if (vms_status & STS$M_SUCCESS)
2332 unix_status = EVMSERR;
2334 msg_status = vms_status & ~STS$M_CONTROL;
2336 facility = vms_status & STS$M_FAC_NO;
2337 fac_sp = vms_status & STS$M_FAC_SP;
2338 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2340 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2346 unix_status = EFAULT;
2348 case SS$_DEVOFFLINE:
2349 unix_status = EBUSY;
2352 unix_status = ENOTCONN;
2360 case SS$_INVFILFOROP:
2364 unix_status = EINVAL;
2366 case SS$_UNSUPPORTED:
2367 unix_status = ENOTSUP;
2372 unix_status = EACCES;
2374 case SS$_DEVICEFULL:
2375 unix_status = ENOSPC;
2378 unix_status = ENODEV;
2380 case SS$_NOSUCHFILE:
2381 case SS$_NOSUCHOBJECT:
2382 unix_status = ENOENT;
2384 case SS$_ABORT: /* Fatal case */
2385 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2386 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2387 unix_status = EINTR;
2390 unix_status = E2BIG;
2393 unix_status = ENOMEM;
2396 unix_status = EPERM;
2398 case SS$_NOSUCHNODE:
2399 case SS$_UNREACHABLE:
2400 unix_status = ESRCH;
2403 unix_status = ECHILD;
2406 if ((facility == 0) && (msg_no < 8)) {
2407 /* These are not real VMS status codes so assume that they are
2408 ** already UNIX status codes
2410 unix_status = msg_no;
2416 /* Translate a POSIX exit code to a UNIX exit code */
2417 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2418 unix_status = (msg_no & 0x07F8) >> 3;
2422 /* Documented traditional behavior for handling VMS child exits */
2423 /*--------------------------------------------------------------*/
2424 if (child_flag != 0) {
2426 /* Success / Informational return 0 */
2427 /*----------------------------------*/
2428 if (msg_no & STS$K_SUCCESS)
2431 /* Warning returns 1 */
2432 /*-------------------*/
2433 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2436 /* Everything else pass through the severity bits */
2437 /*------------------------------------------------*/
2438 return (msg_no & STS$M_SEVERITY);
2441 /* Normal VMS status to ERRNO mapping attempt */
2442 /*--------------------------------------------*/
2443 switch(msg_status) {
2444 /* case RMS$_EOF: */ /* End of File */
2445 case RMS$_FNF: /* File Not Found */
2446 case RMS$_DNF: /* Dir Not Found */
2447 unix_status = ENOENT;
2449 case RMS$_RNF: /* Record Not Found */
2450 unix_status = ESRCH;
2453 unix_status = ENOTDIR;
2456 unix_status = ENODEV;
2461 unix_status = EBADF;
2464 unix_status = EEXIST;
2468 case LIB$_INVSTRDES:
2470 case LIB$_NOSUCHSYM:
2471 case LIB$_INVSYMNAM:
2473 unix_status = EINVAL;
2479 unix_status = E2BIG;
2481 case RMS$_PRV: /* No privilege */
2482 case RMS$_ACC: /* ACP file access failed */
2483 case RMS$_WLK: /* Device write locked */
2484 unix_status = EACCES;
2486 /* case RMS$_NMF: */ /* No more files */
2494 /* Try to guess at what VMS error status should go with a UNIX errno
2495 * value. This is hard to do as there could be many possible VMS
2496 * error statuses that caused the errno value to be set.
2499 int Perl_unix_status_to_vms(int unix_status)
2501 int test_unix_status;
2503 /* Trivial cases first */
2504 /*---------------------*/
2505 if (unix_status == EVMSERR)
2508 /* Is vaxc$errno sane? */
2509 /*---------------------*/
2510 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2511 if (test_unix_status == unix_status)
2514 /* If way out of range, must be VMS code already */
2515 /*-----------------------------------------------*/
2516 if (unix_status > EVMSERR)
2519 /* If out of range, punt */
2520 /*-----------------------*/
2521 if (unix_status > __ERRNO_MAX)
2525 /* Ok, now we have to do it the hard way. */
2526 /*----------------------------------------*/
2527 switch(unix_status) {
2528 case 0: return SS$_NORMAL;
2529 case EPERM: return SS$_NOPRIV;
2530 case ENOENT: return SS$_NOSUCHOBJECT;
2531 case ESRCH: return SS$_UNREACHABLE;
2532 case EINTR: return SS$_ABORT;
2535 case E2BIG: return SS$_BUFFEROVF;
2537 case EBADF: return RMS$_IFI;
2538 case ECHILD: return SS$_NONEXPR;
2540 case ENOMEM: return SS$_INSFMEM;
2541 case EACCES: return SS$_FILACCERR;
2542 case EFAULT: return SS$_ACCVIO;
2544 case EBUSY: return SS$_DEVOFFLINE;
2545 case EEXIST: return RMS$_FEX;
2547 case ENODEV: return SS$_NOSUCHDEV;
2548 case ENOTDIR: return RMS$_DIR;
2550 case EINVAL: return SS$_INVARG;
2556 case ENOSPC: return SS$_DEVICEFULL;
2557 case ESPIPE: return LIB$_INVARG;
2562 case ERANGE: return LIB$_INVARG;
2563 /* case EWOULDBLOCK */
2564 /* case EINPROGRESS */
2567 /* case EDESTADDRREQ */
2569 /* case EPROTOTYPE */
2570 /* case ENOPROTOOPT */
2571 /* case EPROTONOSUPPORT */
2572 /* case ESOCKTNOSUPPORT */
2573 /* case EOPNOTSUPP */
2574 /* case EPFNOSUPPORT */
2575 /* case EAFNOSUPPORT */
2576 /* case EADDRINUSE */
2577 /* case EADDRNOTAVAIL */
2579 /* case ENETUNREACH */
2580 /* case ENETRESET */
2581 /* case ECONNABORTED */
2582 /* case ECONNRESET */
2585 case ENOTCONN: return SS$_CLEARED;
2586 /* case ESHUTDOWN */
2587 /* case ETOOMANYREFS */
2588 /* case ETIMEDOUT */
2589 /* case ECONNREFUSED */
2591 /* case ENAMETOOLONG */
2592 /* case EHOSTDOWN */
2593 /* case EHOSTUNREACH */
2594 /* case ENOTEMPTY */
2606 /* case ECANCELED */
2610 return SS$_UNSUPPORTED;
2616 /* case EABANDONED */
2618 return SS$_ABORT; /* punt */
2621 return SS$_ABORT; /* Should not get here */
2625 /* default piping mailbox size */
2626 #define PERL_BUFSIZ 512
2630 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2632 unsigned long int mbxbufsiz;
2633 static unsigned long int syssize = 0;
2634 unsigned long int dviitm = DVI$_DEVNAM;
2635 char csize[LNM$C_NAMLENGTH+1];
2639 unsigned long syiitm = SYI$_MAXBUF;
2641 * Get the SYSGEN parameter MAXBUF
2643 * If the logical 'PERL_MBX_SIZE' is defined
2644 * use the value of the logical instead of PERL_BUFSIZ, but
2645 * keep the size between 128 and MAXBUF.
2648 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2651 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2652 mbxbufsiz = atoi(csize);
2654 mbxbufsiz = PERL_BUFSIZ;
2656 if (mbxbufsiz < 128) mbxbufsiz = 128;
2657 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2659 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2661 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2662 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2664 } /* end of create_mbx() */
2667 /*{{{ my_popen and my_pclose*/
2669 typedef struct _iosb IOSB;
2670 typedef struct _iosb* pIOSB;
2671 typedef struct _pipe Pipe;
2672 typedef struct _pipe* pPipe;
2673 typedef struct pipe_details Info;
2674 typedef struct pipe_details* pInfo;
2675 typedef struct _srqp RQE;
2676 typedef struct _srqp* pRQE;
2677 typedef struct _tochildbuf CBuf;
2678 typedef struct _tochildbuf* pCBuf;
2681 unsigned short status;
2682 unsigned short count;
2683 unsigned long dvispec;
2686 #pragma member_alignment save
2687 #pragma nomember_alignment quadword
2688 struct _srqp { /* VMS self-relative queue entry */
2689 unsigned long qptr[2];
2691 #pragma member_alignment restore
2692 static RQE RQE_ZERO = {0,0};
2694 struct _tochildbuf {
2697 unsigned short size;
2705 unsigned short chan_in;
2706 unsigned short chan_out;
2708 unsigned int bufsize;
2720 #if defined(PERL_IMPLICIT_CONTEXT)
2721 void *thx; /* Either a thread or an interpreter */
2722 /* pointer, depending on how we're built */
2730 PerlIO *fp; /* file pointer to pipe mailbox */
2731 int useFILE; /* using stdio, not perlio */
2732 int pid; /* PID of subprocess */
2733 int mode; /* == 'r' if pipe open for reading */
2734 int done; /* subprocess has completed */
2735 int waiting; /* waiting for completion/closure */
2736 int closing; /* my_pclose is closing this pipe */
2737 unsigned long completion; /* termination status of subprocess */
2738 pPipe in; /* pipe in to sub */
2739 pPipe out; /* pipe out of sub */
2740 pPipe err; /* pipe of sub's sys$error */
2741 int in_done; /* true when in pipe finished */
2746 struct exit_control_block
2748 struct exit_control_block *flink;
2749 unsigned long int (*exit_routine)();
2750 unsigned long int arg_count;
2751 unsigned long int *status_address;
2752 unsigned long int exit_status;
2755 typedef struct _closed_pipes Xpipe;
2756 typedef struct _closed_pipes* pXpipe;
2758 struct _closed_pipes {
2759 int pid; /* PID of subprocess */
2760 unsigned long completion; /* termination status of subprocess */
2762 #define NKEEPCLOSED 50
2763 static Xpipe closed_list[NKEEPCLOSED];
2764 static int closed_index = 0;
2765 static int closed_num = 0;
2767 #define RETRY_DELAY "0 ::0.20"
2768 #define MAX_RETRY 50
2770 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2771 static unsigned long mypid;
2772 static unsigned long delaytime[2];
2774 static pInfo open_pipes = NULL;
2775 static $DESCRIPTOR(nl_desc, "NL:");
2777 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2781 static unsigned long int
2782 pipe_exit_routine(pTHX)
2785 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2786 int sts, did_stuff, need_eof, j;
2789 flush any pending i/o
2795 PerlIO_flush(info->fp); /* first, flush data */
2797 fflush((FILE *)info->fp);
2803 next we try sending an EOF...ignore if doesn't work, make sure we
2811 _ckvmssts_noperl(sys$setast(0));
2812 if (info->in && !info->in->shut_on_empty) {
2813 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2818 _ckvmssts_noperl(sys$setast(1));
2822 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2824 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2829 _ckvmssts_noperl(sys$setast(0));
2830 if (info->waiting && info->done)
2832 nwait += info->waiting;
2833 _ckvmssts_noperl(sys$setast(1));
2843 _ckvmssts_noperl(sys$setast(0));
2844 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2845 sts = sys$forcex(&info->pid,0,&abort);
2846 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2849 _ckvmssts_noperl(sys$setast(1));
2853 /* again, wait for effect */
2855 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2860 _ckvmssts_noperl(sys$setast(0));
2861 if (info->waiting && info->done)
2863 nwait += info->waiting;
2864 _ckvmssts_noperl(sys$setast(1));
2873 _ckvmssts_noperl(sys$setast(0));
2874 if (!info->done) { /* We tried to be nice . . . */
2875 sts = sys$delprc(&info->pid,0);
2876 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2878 _ckvmssts_noperl(sys$setast(1));
2883 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2884 else if (!(sts & 1)) retsts = sts;
2889 static struct exit_control_block pipe_exitblock =
2890 {(struct exit_control_block *) 0,
2891 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2893 static void pipe_mbxtofd_ast(pPipe p);
2894 static void pipe_tochild1_ast(pPipe p);
2895 static void pipe_tochild2_ast(pPipe p);
2898 popen_completion_ast(pInfo info)
2900 pInfo i = open_pipes;
2905 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2906 closed_list[closed_index].pid = info->pid;
2907 closed_list[closed_index].completion = info->completion;
2909 if (closed_index == NKEEPCLOSED)
2914 if (i == info) break;
2917 if (!i) return; /* unlinked, probably freed too */
2922 Writing to subprocess ...
2923 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2925 chan_out may be waiting for "done" flag, or hung waiting
2926 for i/o completion to child...cancel the i/o. This will
2927 put it into "snarf mode" (done but no EOF yet) that discards
2930 Output from subprocess (stdout, stderr) needs to be flushed and
2931 shut down. We try sending an EOF, but if the mbx is full the pipe
2932 routine should still catch the "shut_on_empty" flag, telling it to
2933 use immediate-style reads so that "mbx empty" -> EOF.
2937 if (info->in && !info->in_done) { /* only for mode=w */
2938 if (info->in->shut_on_empty && info->in->need_wake) {
2939 info->in->need_wake = FALSE;
2940 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2942 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2946 if (info->out && !info->out_done) { /* were we also piping output? */
2947 info->out->shut_on_empty = TRUE;
2948 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2949 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2950 _ckvmssts_noperl(iss);
2953 if (info->err && !info->err_done) { /* we were piping stderr */
2954 info->err->shut_on_empty = TRUE;
2955 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2956 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2957 _ckvmssts_noperl(iss);
2959 _ckvmssts_noperl(sys$setef(pipe_ef));
2963 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2964 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2967 we actually differ from vmstrnenv since we use this to
2968 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2969 are pointing to the same thing
2972 static unsigned short
2973 popen_translate(pTHX_ char *logical, char *result)
2976 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2977 $DESCRIPTOR(d_log,"");
2979 unsigned short length;
2980 unsigned short code;
2982 unsigned short *retlenaddr;
2984 unsigned short l, ifi;
2986 d_log.dsc$a_pointer = logical;
2987 d_log.dsc$w_length = strlen(logical);
2989 itmlst[0].code = LNM$_STRING;
2990 itmlst[0].length = 255;
2991 itmlst[0].buffer_addr = result;
2992 itmlst[0].retlenaddr = &l;
2995 itmlst[1].length = 0;
2996 itmlst[1].buffer_addr = 0;
2997 itmlst[1].retlenaddr = 0;
2999 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3000 if (iss == SS$_NOLOGNAM) {
3004 if (!(iss&1)) lib$signal(iss);
3007 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3008 strip it off and return the ifi, if any
3011 if (result[0] == 0x1b && result[1] == 0x00) {
3012 memmove(&ifi,result+2,2);
3013 strcpy(result,result+4);
3015 return ifi; /* this is the RMS internal file id */
3018 static void pipe_infromchild_ast(pPipe p);
3021 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3022 inside an AST routine without worrying about reentrancy and which Perl
3023 memory allocator is being used.
3025 We read data and queue up the buffers, then spit them out one at a
3026 time to the output mailbox when the output mailbox is ready for one.
3029 #define INITIAL_TOCHILDQUEUE 2
3032 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3036 char mbx1[64], mbx2[64];
3037 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3038 DSC$K_CLASS_S, mbx1},
3039 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3040 DSC$K_CLASS_S, mbx2};
3041 unsigned int dviitm = DVI$_DEVBUFSIZ;
3045 _ckvmssts(lib$get_vm(&n, &p));
3047 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3048 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3049 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3052 p->shut_on_empty = FALSE;
3053 p->need_wake = FALSE;
3056 p->iosb.status = SS$_NORMAL;
3057 p->iosb2.status = SS$_NORMAL;
3063 #ifdef PERL_IMPLICIT_CONTEXT
3067 n = sizeof(CBuf) + p->bufsize;
3069 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3070 _ckvmssts(lib$get_vm(&n, &b));
3071 b->buf = (char *) b + sizeof(CBuf);
3072 _ckvmssts(lib$insqhi(b, &p->free));
3075 pipe_tochild2_ast(p);
3076 pipe_tochild1_ast(p);
3082 /* reads the MBX Perl is writing, and queues */
3085 pipe_tochild1_ast(pPipe p)
3088 int iss = p->iosb.status;
3089 int eof = (iss == SS$_ENDOFFILE);
3091 #ifdef PERL_IMPLICIT_CONTEXT
3097 p->shut_on_empty = TRUE;
3099 _ckvmssts(sys$dassgn(p->chan_in));
3105 b->size = p->iosb.count;
3106 _ckvmssts(sts = lib$insqhi(b, &p->wait));
3108 p->need_wake = FALSE;
3109 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3112 p->retry = 1; /* initial call */
3115 if (eof) { /* flush the free queue, return when done */
3116 int n = sizeof(CBuf) + p->bufsize;
3118 iss = lib$remqti(&p->free, &b);
3119 if (iss == LIB$_QUEWASEMP) return;
3121 _ckvmssts(lib$free_vm(&n, &b));
3125 iss = lib$remqti(&p->free, &b);
3126 if (iss == LIB$_QUEWASEMP) {
3127 int n = sizeof(CBuf) + p->bufsize;
3128 _ckvmssts(lib$get_vm(&n, &b));
3129 b->buf = (char *) b + sizeof(CBuf);
3135 iss = sys$qio(0,p->chan_in,
3136 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3138 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3139 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3144 /* writes queued buffers to output, waits for each to complete before
3148 pipe_tochild2_ast(pPipe p)
3151 int iss = p->iosb2.status;
3152 int n = sizeof(CBuf) + p->bufsize;
3153 int done = (p->info && p->info->done) ||
3154 iss == SS$_CANCEL || iss == SS$_ABORT;
3155 #if defined(PERL_IMPLICIT_CONTEXT)
3160 if (p->type) { /* type=1 has old buffer, dispose */
3161 if (p->shut_on_empty) {
3162 _ckvmssts(lib$free_vm(&n, &b));
3164 _ckvmssts(lib$insqhi(b, &p->free));
3169 iss = lib$remqti(&p->wait, &b);
3170 if (iss == LIB$_QUEWASEMP) {
3171 if (p->shut_on_empty) {
3173 _ckvmssts(sys$dassgn(p->chan_out));
3174 *p->pipe_done = TRUE;
3175 _ckvmssts(sys$setef(pipe_ef));
3177 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3178 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3182 p->need_wake = TRUE;
3192 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3193 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3195 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3196 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3205 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3208 char mbx1[64], mbx2[64];
3209 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3210 DSC$K_CLASS_S, mbx1},
3211 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3212 DSC$K_CLASS_S, mbx2};
3213 unsigned int dviitm = DVI$_DEVBUFSIZ;
3215 int n = sizeof(Pipe);
3216 _ckvmssts(lib$get_vm(&n, &p));
3217 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3218 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3220 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3221 n = p->bufsize * sizeof(char);
3222 _ckvmssts(lib$get_vm(&n, &p->buf));
3223 p->shut_on_empty = FALSE;
3226 p->iosb.status = SS$_NORMAL;
3227 #if defined(PERL_IMPLICIT_CONTEXT)
3230 pipe_infromchild_ast(p);
3238 pipe_infromchild_ast(pPipe p)
3240 int iss = p->iosb.status;
3241 int eof = (iss == SS$_ENDOFFILE);
3242 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3243 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3244 #if defined(PERL_IMPLICIT_CONTEXT)
3248 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3249 _ckvmssts(sys$dassgn(p->chan_out));
3254 input shutdown if EOF from self (done or shut_on_empty)
3255 output shutdown if closing flag set (my_pclose)
3256 send data/eof from child or eof from self
3257 otherwise, re-read (snarf of data from child)
3262 if (myeof && p->chan_in) { /* input shutdown */
3263 _ckvmssts(sys$dassgn(p->chan_in));
3268 if (myeof || kideof) { /* pass EOF to parent */
3269 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3270 pipe_infromchild_ast, p,
3273 } else if (eof) { /* eat EOF --- fall through to read*/
3275 } else { /* transmit data */
3276 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3277 pipe_infromchild_ast,p,
3278 p->buf, p->iosb.count, 0, 0, 0, 0));
3284 /* everything shut? flag as done */
3286 if (!p->chan_in && !p->chan_out) {
3287 *p->pipe_done = TRUE;
3288 _ckvmssts(sys$setef(pipe_ef));
3292 /* write completed (or read, if snarfing from child)
3293 if still have input active,
3294 queue read...immediate mode if shut_on_empty so we get EOF if empty
3296 check if Perl reading, generate EOFs as needed
3302 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3303 pipe_infromchild_ast,p,
3304 p->buf, p->bufsize, 0, 0, 0, 0);
3305 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3307 } else { /* send EOFs for extra reads */
3308 p->iosb.status = SS$_ENDOFFILE;
3309 p->iosb.dvispec = 0;
3310 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3312 pipe_infromchild_ast, p, 0, 0, 0, 0));
3318 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3322 unsigned long dviitm = DVI$_DEVBUFSIZ;
3324 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3325 DSC$K_CLASS_S, mbx};
3326 int n = sizeof(Pipe);
3328 /* things like terminals and mbx's don't need this filter */
3329 if (fd && fstat(fd,&s) == 0) {
3330 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3332 unsigned short dev_len;
3333 struct dsc$descriptor_s d_dev;
3335 struct item_list_3 items[3];
3337 unsigned short dvi_iosb[4];
3339 cptr = getname(fd, out, 1);
3340 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3341 d_dev.dsc$a_pointer = out;
3342 d_dev.dsc$w_length = strlen(out);
3343 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3344 d_dev.dsc$b_class = DSC$K_CLASS_S;
3347 items[0].code = DVI$_DEVCHAR;
3348 items[0].bufadr = &devchar;
3349 items[0].retadr = NULL;
3351 items[1].code = DVI$_FULLDEVNAM;
3352 items[1].bufadr = device;
3353 items[1].retadr = &dev_len;
3357 status = sys$getdviw
3358 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3360 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3361 device[dev_len] = 0;
3363 if (!(devchar & DEV$M_DIR)) {
3364 strcpy(out, device);
3370 _ckvmssts(lib$get_vm(&n, &p));
3371 p->fd_out = dup(fd);
3372 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3373 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3374 n = (p->bufsize+1) * sizeof(char);
3375 _ckvmssts(lib$get_vm(&n, &p->buf));
3376 p->shut_on_empty = FALSE;
3381 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3382 pipe_mbxtofd_ast, p,
3383 p->buf, p->bufsize, 0, 0, 0, 0));
3389 pipe_mbxtofd_ast(pPipe p)
3391 int iss = p->iosb.status;
3392 int done = p->info->done;
3394 int eof = (iss == SS$_ENDOFFILE);
3395 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3396 int err = !(iss&1) && !eof;
3397 #if defined(PERL_IMPLICIT_CONTEXT)
3401 if (done && myeof) { /* end piping */
3403 sys$dassgn(p->chan_in);
3404 *p->pipe_done = TRUE;
3405 _ckvmssts(sys$setef(pipe_ef));
3409 if (!err && !eof) { /* good data to send to file */
3410 p->buf[p->iosb.count] = '\n';
3411 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3414 if (p->retry < MAX_RETRY) {
3415 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3425 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3426 pipe_mbxtofd_ast, p,
3427 p->buf, p->bufsize, 0, 0, 0, 0);
3428 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3433 typedef struct _pipeloc PLOC;
3434 typedef struct _pipeloc* pPLOC;
3438 char dir[NAM$C_MAXRSS+1];
3440 static pPLOC head_PLOC = 0;
3443 free_pipelocs(pTHX_ void *head)
3446 pPLOC *pHead = (pPLOC *)head;
3458 store_pipelocs(pTHX)
3467 char temp[NAM$C_MAXRSS+1];
3471 free_pipelocs(aTHX_ &head_PLOC);
3473 /* the . directory from @INC comes last */
3475 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3476 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3477 p->next = head_PLOC;
3479 strcpy(p->dir,"./");
3481 /* get the directory from $^X */
3483 unixdir = PerlMem_malloc(VMS_MAXRSS);
3484 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3486 #ifdef PERL_IMPLICIT_CONTEXT
3487 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3489 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3491 strcpy(temp, PL_origargv[0]);
3492 x = strrchr(temp,']');
3494 x = strrchr(temp,'>');
3496 /* It could be a UNIX path */
3497 x = strrchr(temp,'/');
3503 /* Got a bare name, so use default directory */
3508 if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3509 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3510 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3511 p->next = head_PLOC;
3513 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3514 p->dir[NAM$C_MAXRSS] = '\0';
3518 /* reverse order of @INC entries, skip "." since entered above */
3520 #ifdef PERL_IMPLICIT_CONTEXT
3523 if (PL_incgv) av = GvAVn(PL_incgv);
3525 for (i = 0; av && i <= AvFILL(av); i++) {
3526 dirsv = *av_fetch(av,i,TRUE);
3528 if (SvROK(dirsv)) continue;
3529 dir = SvPVx(dirsv,n_a);
3530 if (strcmp(dir,".") == 0) continue;
3531 if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3534 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3535 p->next = head_PLOC;
3537 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3538 p->dir[NAM$C_MAXRSS] = '\0';
3541 /* most likely spot (ARCHLIB) put first in the list */
3544 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3545 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3546 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3547 p->next = head_PLOC;
3549 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3550 p->dir[NAM$C_MAXRSS] = '\0';
3553 PerlMem_free(unixdir);
3557 Perl_cando_by_name_int
3558 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3559 #if !defined(PERL_IMPLICIT_CONTEXT)
3560 #define cando_by_name_int Perl_cando_by_name_int
3562 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3568 static int vmspipe_file_status = 0;
3569 static char vmspipe_file[NAM$C_MAXRSS+1];
3571 /* already found? Check and use ... need read+execute permission */
3573 if (vmspipe_file_status == 1) {
3574 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3575 && cando_by_name_int
3576 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3577 return vmspipe_file;
3579 vmspipe_file_status = 0;
3582 /* scan through stored @INC, $^X */
3584 if (vmspipe_file_status == 0) {
3585 char file[NAM$C_MAXRSS+1];
3586 pPLOC p = head_PLOC;
3591 strcpy(file, p->dir);
3592 dirlen = strlen(file);
3593 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3594 file[NAM$C_MAXRSS] = '\0';
3597 exp_res = do_rmsexpand
3598 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3599 if (!exp_res) continue;
3601 if (cando_by_name_int
3602 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3603 && cando_by_name_int
3604 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3605 vmspipe_file_status = 1;
3606 return vmspipe_file;
3609 vmspipe_file_status = -1; /* failed, use tempfiles */
3616 vmspipe_tempfile(pTHX)
3618 char file[NAM$C_MAXRSS+1];
3620 static int index = 0;
3624 /* create a tempfile */
3626 /* we can't go from W, shr=get to R, shr=get without
3627 an intermediate vulnerable state, so don't bother trying...
3629 and lib$spawn doesn't shr=put, so have to close the write
3631 So... match up the creation date/time and the FID to
3632 make sure we're dealing with the same file
3637 if (!decc_filename_unix_only) {
3638 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3639 fp = fopen(file,"w");
3641 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3642 fp = fopen(file,"w");
3644 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3645 fp = fopen(file,"w");
3650 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3651 fp = fopen(file,"w");
3653 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3654 fp = fopen(file,"w");
3656 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3657 fp = fopen(file,"w");
3661 if (!fp) return 0; /* we're hosed */
3663 fprintf(fp,"$! 'f$verify(0)'\n");
3664 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3665 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3666 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3667 fprintf(fp,"$ perl_on = \"set noon\"\n");
3668 fprintf(fp,"$ perl_exit = \"exit\"\n");
3669 fprintf(fp,"$ perl_del = \"delete\"\n");
3670 fprintf(fp,"$ pif = \"if\"\n");
3671 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3672 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3673 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3674 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3675 fprintf(fp,"$! --- build command line to get max possible length\n");
3676 fprintf(fp,"$c=perl_popen_cmd0\n");
3677 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3678 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3679 fprintf(fp,"$x=perl_popen_cmd3\n");
3680 fprintf(fp,"$c=c+x\n");
3681 fprintf(fp,"$ perl_on\n");
3682 fprintf(fp,"$ 'c'\n");
3683 fprintf(fp,"$ perl_status = $STATUS\n");
3684 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3685 fprintf(fp,"$ perl_exit 'perl_status'\n");
3688 fgetname(fp, file, 1);
3689 fstat(fileno(fp), (struct stat *)&s0);
3692 if (decc_filename_unix_only)
3693 do_tounixspec(file, file, 0, NULL);
3694 fp = fopen(file,"r","shr=get");
3696 fstat(fileno(fp), (struct stat *)&s1);
3698 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3699 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3710 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3712 static int handler_set_up = FALSE;
3713 unsigned long int sts, flags = CLI$M_NOWAIT;
3714 /* The use of a GLOBAL table (as was done previously) rendered
3715 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3716 * environment. Hence we've switched to LOCAL symbol table.
3718 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3720 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3721 char *in, *out, *err, mbx[512];
3723 char tfilebuf[NAM$C_MAXRSS+1];
3725 char cmd_sym_name[20];
3726 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3727 DSC$K_CLASS_S, symbol};
3728 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3730 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3731 DSC$K_CLASS_S, cmd_sym_name};
3732 struct dsc$descriptor_s *vmscmd;
3733 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3734 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3735 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3737 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3739 /* once-per-program initialization...
3740 note that the SETAST calls and the dual test of pipe_ef
3741 makes sure that only the FIRST thread through here does
3742 the initialization...all other threads wait until it's
3745 Yeah, uglier than a pthread call, it's got all the stuff inline
3746 rather than in a separate routine.
3750 _ckvmssts(sys$setast(0));
3752 unsigned long int pidcode = JPI$_PID;
3753 $DESCRIPTOR(d_delay, RETRY_DELAY);
3754 _ckvmssts(lib$get_ef(&pipe_ef));
3755 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3756 _ckvmssts(sys$bintim(&d_delay, delaytime));
3758 if (!handler_set_up) {
3759 _ckvmssts(sys$dclexh(&pipe_exitblock));
3760 handler_set_up = TRUE;
3762 _ckvmssts(sys$setast(1));
3765 /* see if we can find a VMSPIPE.COM */
3768 vmspipe = find_vmspipe(aTHX);
3770 strcpy(tfilebuf+1,vmspipe);
3771 } else { /* uh, oh...we're in tempfile hell */
3772 tpipe = vmspipe_tempfile(aTHX);
3773 if (!tpipe) { /* a fish popular in Boston */
3774 if (ckWARN(WARN_PIPE)) {
3775 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3779 fgetname(tpipe,tfilebuf+1,1);
3781 vmspipedsc.dsc$a_pointer = tfilebuf;
3782 vmspipedsc.dsc$w_length = strlen(tfilebuf);
3784 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3787 case RMS$_FNF: case RMS$_DNF:
3788 set_errno(ENOENT); break;
3790 set_errno(ENOTDIR); break;
3792 set_errno(ENODEV); break;
3794 set_errno(EACCES); break;
3796 set_errno(EINVAL); break;
3797 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3798 set_errno(E2BIG); break;
3799 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3800 _ckvmssts(sts); /* fall through */
3801 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3804 set_vaxc_errno(sts);
3805 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3806 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3812 _ckvmssts(lib$get_vm(&n, &info));
3814 strcpy(mode,in_mode);
3817 info->completion = 0;
3818 info->closing = FALSE;
3825 info->in_done = TRUE;
3826 info->out_done = TRUE;
3827 info->err_done = TRUE;
3829 in = PerlMem_malloc(VMS_MAXRSS);
3830 if (in == NULL) _ckvmssts(SS$_INSFMEM);
3831 out = PerlMem_malloc(VMS_MAXRSS);
3832 if (out == NULL) _ckvmssts(SS$_INSFMEM);
3833 err = PerlMem_malloc(VMS_MAXRSS);
3834 if (err == NULL) _ckvmssts(SS$_INSFMEM);
3836 in[0] = out[0] = err[0] = '\0';
3838 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
3842 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
3847 if (*mode == 'r') { /* piping from subroutine */
3849 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3851 info->out->pipe_done = &info->out_done;
3852 info->out_done = FALSE;
3853 info->out->info = info;
3855 if (!info->useFILE) {
3856 info->fp = PerlIO_open(mbx, mode);
3858 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3859 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3862 if (!info->fp && info->out) {
3863 sys$cancel(info->out->chan_out);
3865 while (!info->out_done) {
3867 _ckvmssts(sys$setast(0));
3868 done = info->out_done;
3869 if (!done) _ckvmssts(sys$clref(pipe_ef));
3870 _ckvmssts(sys$setast(1));
3871 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3874 if (info->out->buf) {
3875 n = info->out->bufsize * sizeof(char);
3876 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3879 _ckvmssts(lib$free_vm(&n, &info->out));
3881 _ckvmssts(lib$free_vm(&n, &info));
3886 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3888 info->err->pipe_done = &info->err_done;
3889 info->err_done = FALSE;
3890 info->err->info = info;
3893 } else if (*mode == 'w') { /* piping to subroutine */
3895 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3897 info->out->pipe_done = &info->out_done;
3898 info->out_done = FALSE;
3899 info->out->info = info;
3902 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3904 info->err->pipe_done = &info->err_done;
3905 info->err_done = FALSE;
3906 info->err->info = info;
3909 info->in = pipe_tochild_setup(aTHX_ in,mbx);
3910 if (!info->useFILE) {
3911 info->fp = PerlIO_open(mbx, mode);
3913 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3914 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3918 info->in->pipe_done = &info->in_done;
3919 info->in_done = FALSE;
3920 info->in->info = info;
3924 if (!info->fp && info->in) {
3926 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3927 0, 0, 0, 0, 0, 0, 0, 0));
3929 while (!info->in_done) {
3931 _ckvmssts(sys$setast(0));
3932 done = info->in_done;
3933 if (!done) _ckvmssts(sys$clref(pipe_ef));
3934 _ckvmssts(sys$setast(1));
3935 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3938 if (info->in->buf) {
3939 n = info->in->bufsize * sizeof(char);
3940 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3943 _ckvmssts(lib$free_vm(&n, &info->in));
3945 _ckvmssts(lib$free_vm(&n, &info));
3951 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
3952 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3954 info->out->pipe_done = &info->out_done;
3955 info->out_done = FALSE;
3956 info->out->info = info;
3959 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3961 info->err->pipe_done = &info->err_done;
3962 info->err_done = FALSE;
3963 info->err->info = info;
3967 symbol[MAX_DCL_SYMBOL] = '\0';
3969 strncpy(symbol, in, MAX_DCL_SYMBOL);
3970 d_symbol.dsc$w_length = strlen(symbol);
3971 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3973 strncpy(symbol, err, MAX_DCL_SYMBOL);
3974 d_symbol.dsc$w_length = strlen(symbol);
3975 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3977 strncpy(symbol, out, MAX_DCL_SYMBOL);
3978 d_symbol.dsc$w_length = strlen(symbol);
3979 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3981 /* Done with the names for the pipes */
3986 p = vmscmd->dsc$a_pointer;
3987 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
3988 if (*p == '$') p++; /* remove leading $ */
3989 while (*p == ' ' || *p == '\t') p++;
3991 for (j = 0; j < 4; j++) {
3992 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3993 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3995 strncpy(symbol, p, MAX_DCL_SYMBOL);
3996 d_symbol.dsc$w_length = strlen(symbol);
3997 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3999 if (strlen(p) > MAX_DCL_SYMBOL) {
4000 p += MAX_DCL_SYMBOL;
4005 _ckvmssts(sys$setast(0));
4006 info->next=open_pipes; /* prepend to list */
4008 _ckvmssts(sys$setast(1));
4009 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4010 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4011 * have SYS$COMMAND if we need it.
4013 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4014 0, &info->pid, &info->completion,
4015 0, popen_completion_ast,info,0,0,0));
4017 /* if we were using a tempfile, close it now */
4019 if (tpipe) fclose(tpipe);
4021 /* once the subprocess is spawned, it has copied the symbols and
4022 we can get rid of ours */
4024 for (j = 0; j < 4; j++) {
4025 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4026 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4027 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4029 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4030 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4031 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4032 vms_execfree(vmscmd);
4034 #ifdef PERL_IMPLICIT_CONTEXT
4037 PL_forkprocess = info->pid;
4042 _ckvmssts(sys$setast(0));
4044 if (!done) _ckvmssts(sys$clref(pipe_ef));
4045 _ckvmssts(sys$setast(1));
4046 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4048 *psts = info->completion;
4049 /* Caller thinks it is open and tries to close it. */
4050 /* This causes some problems, as it changes the error status */
4051 /* my_pclose(info->fp); */
4056 } /* end of safe_popen */
4059 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4061 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4065 TAINT_PROPER("popen");
4066 PERL_FLUSHALL_FOR_CHILD;
4067 return safe_popen(aTHX_ cmd,mode,&sts);
4072 /*{{{ I32 my_pclose(PerlIO *fp)*/
4073 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4075 pInfo info, last = NULL;
4076 unsigned long int retsts;
4079 for (info = open_pipes; info != NULL; last = info, info = info->next)
4080 if (info->fp == fp) break;
4082 if (info == NULL) { /* no such pipe open */
4083 set_errno(ECHILD); /* quoth POSIX */
4084 set_vaxc_errno(SS$_NONEXPR);
4088 /* If we were writing to a subprocess, insure that someone reading from
4089 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4090 * produce an EOF record in the mailbox.
4092 * well, at least sometimes it *does*, so we have to watch out for
4093 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4097 PerlIO_flush(info->fp); /* first, flush data */
4099 fflush((FILE *)info->fp);
4102 _ckvmssts(sys$setast(0));
4103 info->closing = TRUE;
4104 done = info->done && info->in_done && info->out_done && info->err_done;
4105 /* hanging on write to Perl's input? cancel it */
4106 if (info->mode == 'r' && info->out && !info->out_done) {
4107 if (info->out->chan_out) {
4108 _ckvmssts(sys$cancel(info->out->chan_out));
4109 if (!info->out->chan_in) { /* EOF generation, need AST */
4110 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4114 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4115 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4117 _ckvmssts(sys$setast(1));
4120 PerlIO_close(info->fp);
4122 fclose((FILE *)info->fp);
4125 we have to wait until subprocess completes, but ALSO wait until all
4126 the i/o completes...otherwise we'll be freeing the "info" structure
4127 that the i/o ASTs could still be using...
4131 _ckvmssts(sys$setast(0));
4132 done = info->done && info->in_done && info->out_done && info->err_done;
4133 if (!done) _ckvmssts(sys$clref(pipe_ef));
4134 _ckvmssts(sys$setast(1));
4135 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4137 retsts = info->completion;
4139 /* remove from list of open pipes */
4140 _ckvmssts(sys$setast(0));
4141 if (last) last->next = info->next;
4142 else open_pipes = info->next;
4143 _ckvmssts(sys$setast(1));
4145 /* free buffers and structures */
4148 if (info->in->buf) {
4149 n = info->in->bufsize * sizeof(char);
4150 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4153 _ckvmssts(lib$free_vm(&n, &info->in));
4156 if (info->out->buf) {
4157 n = info->out->bufsize * sizeof(char);
4158 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4161 _ckvmssts(lib$free_vm(&n, &info->out));
4164 if (info->err->buf) {
4165 n = info->err->bufsize * sizeof(char);
4166 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4169 _ckvmssts(lib$free_vm(&n, &info->err));
4172 _ckvmssts(lib$free_vm(&n, &info));
4176 } /* end of my_pclose() */
4178 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4179 /* Roll our own prototype because we want this regardless of whether
4180 * _VMS_WAIT is defined.
4182 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4184 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4185 created with popen(); otherwise partially emulate waitpid() unless
4186 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4187 Also check processes not considered by the CRTL waitpid().
4189 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4191 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4198 if (statusp) *statusp = 0;
4200 for (info = open_pipes; info != NULL; info = info->next)
4201 if (info->pid == pid) break;
4203 if (info != NULL) { /* we know about this child */
4204 while (!info->done) {
4205 _ckvmssts(sys$setast(0));
4207 if (!done) _ckvmssts(sys$clref(pipe_ef));
4208 _ckvmssts(sys$setast(1));
4209 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4212 if (statusp) *statusp = info->completion;
4216 /* child that already terminated? */
4218 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4219 if (closed_list[j].pid == pid) {
4220 if (statusp) *statusp = closed_list[j].completion;
4225 /* fall through if this child is not one of our own pipe children */
4227 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4229 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4230 * in 7.2 did we get a version that fills in the VMS completion
4231 * status as Perl has always tried to do.
4234 sts = __vms_waitpid( pid, statusp, flags );
4236 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4239 /* If the real waitpid tells us the child does not exist, we
4240 * fall through here to implement waiting for a child that
4241 * was created by some means other than exec() (say, spawned
4242 * from DCL) or to wait for a process that is not a subprocess
4243 * of the current process.
4246 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4249 $DESCRIPTOR(intdsc,"0 00:00:01");
4250 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4251 unsigned long int pidcode = JPI$_PID, mypid;
4252 unsigned long int interval[2];
4253 unsigned int jpi_iosb[2];
4254 struct itmlst_3 jpilist[2] = {
4255 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4260 /* Sorry folks, we don't presently implement rooting around for
4261 the first child we can find, and we definitely don't want to
4262 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4268 /* Get the owner of the child so I can warn if it's not mine. If the
4269 * process doesn't exist or I don't have the privs to look at it,
4270 * I can go home early.
4272 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4273 if (sts & 1) sts = jpi_iosb[0];
4285 set_vaxc_errno(sts);
4289 if (ckWARN(WARN_EXEC)) {
4290 /* remind folks they are asking for non-standard waitpid behavior */
4291 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4292 if (ownerpid != mypid)
4293 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4294 "waitpid: process %x is not a child of process %x",
4298 /* simply check on it once a second until it's not there anymore. */
4300 _ckvmssts(sys$bintim(&intdsc,interval));
4301 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4302 _ckvmssts(sys$schdwk(0,0,interval,0));
4303 _ckvmssts(sys$hiber());
4305 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4310 } /* end of waitpid() */
4315 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4317 my_gconvert(double val, int ndig, int trail, char *buf)
4319 static char __gcvtbuf[DBL_DIG+1];
4322 loc = buf ? buf : __gcvtbuf;
4324 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4326 sprintf(loc,"%.*g",ndig,val);
4332 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4333 return gcvt(val,ndig,loc);
4336 loc[0] = '0'; loc[1] = '\0';
4343 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4344 static int rms_free_search_context(struct FAB * fab)
4348 nam = fab->fab$l_nam;
4349 nam->nam$b_nop |= NAM$M_SYNCHK;
4350 nam->nam$l_rlf = NULL;
4352 return sys$parse(fab, NULL, NULL);
4355 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4356 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4357 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4358 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4359 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4360 #define rms_nam_esll(nam) nam.nam$b_esl
4361 #define rms_nam_esl(nam) nam.nam$b_esl
4362 #define rms_nam_name(nam) nam.nam$l_name
4363 #define rms_nam_namel(nam) nam.nam$l_name
4364 #define rms_nam_type(nam) nam.nam$l_type
4365 #define rms_nam_typel(nam) nam.nam$l_type
4366 #define rms_nam_ver(nam) nam.nam$l_ver
4367 #define rms_nam_verl(nam) nam.nam$l_ver
4368 #define rms_nam_rsll(nam) nam.nam$b_rsl
4369 #define rms_nam_rsl(nam) nam.nam$b_rsl
4370 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4371 #define rms_set_fna(fab, nam, name, size) \
4372 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4373 #define rms_get_fna(fab, nam) fab.fab$l_fna
4374 #define rms_set_dna(fab, nam, name, size) \
4375 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4376 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4377 #define rms_set_esa(fab, nam, name, size) \
4378 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4379 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4380 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4381 #define rms_set_rsa(nam, name, size) \
4382 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4383 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4384 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4385 #define rms_nam_name_type_l_size(nam) \
4386 (nam.nam$b_name + nam.nam$b_type)
4388 static int rms_free_search_context(struct FAB * fab)
4392 nam = fab->fab$l_naml;
4393 nam->naml$b_nop |= NAM$M_SYNCHK;
4394 nam->naml$l_rlf = NULL;
4395 nam->naml$l_long_defname_size = 0;
4398 return sys$parse(fab, NULL, NULL);
4401 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4402 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4403 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4404 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4405 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4406 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4407 #define rms_nam_esl(nam) nam.naml$b_esl
4408 #define rms_nam_name(nam) nam.naml$l_name
4409 #define rms_nam_namel(nam) nam.naml$l_long_name
4410 #define rms_nam_type(nam) nam.naml$l_type
4411 #define rms_nam_typel(nam) nam.naml$l_long_type
4412 #define rms_nam_ver(nam) nam.naml$l_ver
4413 #define rms_nam_verl(nam) nam.naml$l_long_ver
4414 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4415 #define rms_nam_rsl(nam) nam.naml$b_rsl
4416 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4417 #define rms_set_fna(fab, nam, name, size) \
4418 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4419 nam.naml$l_long_filename_size = size; \
4420 nam.naml$l_long_filename = name;}
4421 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4422 #define rms_set_dna(fab, nam, name, size) \
4423 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4424 nam.naml$l_long_defname_size = size; \
4425 nam.naml$l_long_defname = name; }
4426 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4427 #define rms_set_esa(fab, nam, name, size) \
4428 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4429 nam.naml$l_long_expand_alloc = size; \
4430 nam.naml$l_long_expand = name; }
4431 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4432 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4433 nam.naml$l_long_expand = l_name; \
4434 nam.naml$l_long_expand_alloc = l_size; }
4435 #define rms_set_rsa(nam, name, size) \
4436 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4437 nam.naml$l_long_result = name; \
4438 nam.naml$l_long_result_alloc = size; }
4439 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4440 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4441 nam.naml$l_long_result = l_name; \
4442 nam.naml$l_long_result_alloc = l_size; }
4443 #define rms_nam_name_type_l_size(nam) \
4444 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4448 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4449 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4450 * to expand file specification. Allows for a single default file
4451 * specification and a simple mask of options. If outbuf is non-NULL,
4452 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4453 * the resultant file specification is placed. If outbuf is NULL, the
4454 * resultant file specification is placed into a static buffer.
4455 * The third argument, if non-NULL, is taken to be a default file
4456 * specification string. The fourth argument is unused at present.
4457 * rmesexpand() returns the address of the resultant string if
4458 * successful, and NULL on error.
4460 * New functionality for previously unused opts value:
4461 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4462 * PERL_RMSEXPAND_M_LONG - Want output in long formst
4463 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4465 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4469 (pTHX_ const char *filespec,
4472 const char *defspec,
4477 static char __rmsexpand_retbuf[VMS_MAXRSS];
4478 char * vmsfspec, *tmpfspec;
4479 char * esa, *cp, *out = NULL;
4483 struct FAB myfab = cc$rms_fab;
4484 rms_setup_nam(mynam);
4486 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4489 /* temp hack until UTF8 is actually implemented */
4490 if (fs_utf8 != NULL)
4493 if (!filespec || !*filespec) {
4494 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4498 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4499 else outbuf = __rmsexpand_retbuf;
4507 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4508 isunix = is_unix_filespec(filespec);
4510 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4511 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4512 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4513 PerlMem_free(vmsfspec);
4518 filespec = vmsfspec;
4520 /* Unless we are forcing to VMS format, a UNIX input means
4521 * UNIX output, and that requires long names to be used
4523 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4524 opts |= PERL_RMSEXPAND_M_LONG;
4531 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4532 rms_bind_fab_nam(myfab, mynam);
4534 if (defspec && *defspec) {
4536 t_isunix = is_unix_filespec(defspec);
4538 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4539 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4540 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4541 PerlMem_free(tmpfspec);
4542 if (vmsfspec != NULL)
4543 PerlMem_free(vmsfspec);
4550 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4553 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4554 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4555 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4556 esal = PerlMem_malloc(VMS_MAXRSS);
4557 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4559 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4561 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4562 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4565 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4566 outbufl = PerlMem_malloc(VMS_MAXRSS);
4567 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4568 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4570 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4574 #ifdef NAM$M_NO_SHORT_UPCASE
4575 if (decc_efs_case_preserve)
4576 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4579 /* First attempt to parse as an existing file */
4580 retsts = sys$parse(&myfab,0,0);
4581 if (!(retsts & STS$K_SUCCESS)) {
4583 /* Could not find the file, try as syntax only if error is not fatal */
4584 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4585 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4586 retsts = sys$parse(&myfab,0,0);
4587 if (retsts & STS$K_SUCCESS) goto expanded;
4590 /* Still could not parse the file specification */
4591 /*----------------------------------------------*/
4592 sts = rms_free_search_context(&myfab); /* Free search context */
4593 if (out) Safefree(out);
4594 if (tmpfspec != NULL)
4595 PerlMem_free(tmpfspec);
4596 if (vmsfspec != NULL)
4597 PerlMem_free(vmsfspec);
4598 if (outbufl != NULL)
4599 PerlMem_free(outbufl);
4602 set_vaxc_errno(retsts);
4603 if (retsts == RMS$_PRV) set_errno(EACCES);
4604 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4605 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4606 else set_errno(EVMSERR);
4609 retsts = sys$search(&myfab,0,0);
4610 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4611 sts = rms_free_search_context(&myfab); /* Free search context */
4612 if (out) Safefree(out);
4613 if (tmpfspec != NULL)
4614 PerlMem_free(tmpfspec);
4615 if (vmsfspec != NULL)
4616 PerlMem_free(vmsfspec);
4617 if (outbufl != NULL)
4618 PerlMem_free(outbufl);
4621 set_vaxc_errno(retsts);
4622 if (retsts == RMS$_PRV) set_errno(EACCES);
4623 else set_errno(EVMSERR);
4627 /* If the input filespec contained any lowercase characters,
4628 * downcase the result for compatibility with Unix-minded code. */
4630 if (!decc_efs_case_preserve) {
4631 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4632 if (islower(*tbuf)) { haslower = 1; break; }
4635 /* Is a long or a short name expected */
4636 /*------------------------------------*/
4637 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4638 if (rms_nam_rsll(mynam)) {
4640 speclen = rms_nam_rsll(mynam);
4643 tbuf = esal; /* Not esa */
4644 speclen = rms_nam_esll(mynam);
4648 if (rms_nam_rsl(mynam)) {
4650 speclen = rms_nam_rsl(mynam);
4653 tbuf = esa; /* Not esal */
4654 speclen = rms_nam_esl(mynam);
4657 tbuf[speclen] = '\0';
4659 /* Trim off null fields added by $PARSE
4660 * If type > 1 char, must have been specified in original or default spec
4661 * (not true for version; $SEARCH may have added version of existing file).
4663 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4664 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4665 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4666 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4669 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4670 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4672 if (trimver || trimtype) {
4673 if (defspec && *defspec) {
4674 char *defesal = NULL;
4675 defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4676 if (defesal != NULL) {
4677 struct FAB deffab = cc$rms_fab;
4678 rms_setup_nam(defnam);
4680 rms_bind_fab_nam(deffab, defnam);
4684 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4686 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4688 rms_clear_nam_nop(defnam);
4689 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4690 #ifdef NAM$M_NO_SHORT_UPCASE
4691 if (decc_efs_case_preserve)
4692 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4694 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4696 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4699 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4702 PerlMem_free(defesal);
4706 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4707 if (*(rms_nam_verl(mynam)) != '\"')
4708 speclen = rms_nam_verl(mynam) - tbuf;
4711 if (*(rms_nam_ver(mynam)) != '\"')
4712 speclen = rms_nam_ver(mynam) - tbuf;
4716 /* If we didn't already trim version, copy down */
4717 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4718 if (speclen > rms_nam_verl(mynam) - tbuf)
4720 (rms_nam_typel(mynam),
4721 rms_nam_verl(mynam),
4722 speclen - (rms_nam_verl(mynam) - tbuf));
4723 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4726 if (speclen > rms_nam_ver(mynam) - tbuf)
4728 (rms_nam_type(mynam),
4730 speclen - (rms_nam_ver(mynam) - tbuf));
4731 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4736 /* Done with these copies of the input files */
4737 /*-------------------------------------------*/
4738 if (vmsfspec != NULL)
4739 PerlMem_free(vmsfspec);
4740 if (tmpfspec != NULL)
4741 PerlMem_free(tmpfspec);
4743 /* If we just had a directory spec on input, $PARSE "helpfully"
4744 * adds an empty name and type for us */
4745 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4746 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4747 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
4748 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4749 speclen = rms_nam_namel(mynam) - tbuf;
4752 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4753 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
4754 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4755 speclen = rms_nam_name(mynam) - tbuf;
4758 /* Posix format specifications must have matching quotes */
4759 if (speclen < (VMS_MAXRSS - 1)) {
4760 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4761 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4762 tbuf[speclen] = '\"';
4767 tbuf[speclen] = '\0';
4768 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4770 /* Have we been working with an expanded, but not resultant, spec? */
4771 /* Also, convert back to Unix syntax if necessary. */
4773 if (!rms_nam_rsll(mynam)) {
4775 if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
4776 if (out) Safefree(out);
4779 if (outbufl != NULL)
4780 PerlMem_free(outbufl);
4784 else strcpy(outbuf,esa);
4787 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4788 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4789 if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
4790 if (out) Safefree(out);
4793 PerlMem_free(tmpfspec);
4794 if (outbufl != NULL)
4795 PerlMem_free(outbufl);
4798 strcpy(outbuf,tmpfspec);
4799 PerlMem_free(tmpfspec);
4802 rms_set_rsal(mynam, NULL, 0, NULL, 0);
4803 sts = rms_free_search_context(&myfab); /* Free search context */
4806 if (outbufl != NULL)
4807 PerlMem_free(outbufl);
4811 /* External entry points */
4812 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4813 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
4814 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4815 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
4816 char *Perl_rmsexpand_utf8
4817 (pTHX_ const char *spec, char *buf, const char *def,
4818 unsigned opt, int * fs_utf8, int * dfs_utf8)
4819 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
4820 char *Perl_rmsexpand_utf8_ts
4821 (pTHX_ const char *spec, char *buf, const char *def,
4822 unsigned opt, int * fs_utf8, int * dfs_utf8)
4823 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
4827 ** The following routines are provided to make life easier when
4828 ** converting among VMS-style and Unix-style directory specifications.
4829 ** All will take input specifications in either VMS or Unix syntax. On
4830 ** failure, all return NULL. If successful, the routines listed below
4831 ** return a pointer to a buffer containing the appropriately
4832 ** reformatted spec (and, therefore, subsequent calls to that routine
4833 ** will clobber the result), while the routines of the same names with
4834 ** a _ts suffix appended will return a pointer to a mallocd string
4835 ** containing the appropriately reformatted spec.
4836 ** In all cases, only explicit syntax is altered; no check is made that
4837 ** the resulting string is valid or that the directory in question
4840 ** fileify_dirspec() - convert a directory spec into the name of the
4841 ** directory file (i.e. what you can stat() to see if it's a dir).
4842 ** The style (VMS or Unix) of the result is the same as the style
4843 ** of the parameter passed in.
4844 ** pathify_dirspec() - convert a directory spec into a path (i.e.
4845 ** what you prepend to a filename to indicate what directory it's in).
4846 ** The style (VMS or Unix) of the result is the same as the style
4847 ** of the parameter passed in.
4848 ** tounixpath() - convert a directory spec into a Unix-style path.
4849 ** tovmspath() - convert a directory spec into a VMS-style path.
4850 ** tounixspec() - convert any file spec into a Unix-style file spec.
4851 ** tovmsspec() - convert any file spec into a VMS-style spec.
4852 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
4854 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
4855 ** Permission is given to distribute this code as part of the Perl
4856 ** standard distribution under the terms of the GNU General Public
4857 ** License or the Perl Artistic License. Copies of each may be
4858 ** found in the Perl standard distribution.
4861 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
4862 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
4864 static char __fileify_retbuf[VMS_MAXRSS];
4865 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4866 char *retspec, *cp1, *cp2, *lastdir;
4867 char *trndir, *vmsdir;
4868 unsigned short int trnlnm_iter_count;
4870 if (utf8_fl != NULL)
4873 if (!dir || !*dir) {
4874 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4876 dirlen = strlen(dir);
4877 while (dirlen && dir[dirlen-1] == '/') --dirlen;
4878 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4879 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4886 if (dirlen > (VMS_MAXRSS - 1)) {
4887 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4890 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4891 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4892 if (!strpbrk(dir+1,"/]>:") &&
4893 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4894 strcpy(trndir,*dir == '/' ? dir + 1: dir);
4895 trnlnm_iter_count = 0;
4896 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4897 trnlnm_iter_count++;
4898 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4900 dirlen = strlen(trndir);
4903 strncpy(trndir,dir,dirlen);
4904 trndir[dirlen] = '\0';
4907 /* At this point we are done with *dir and use *trndir which is a
4908 * copy that can be modified. *dir must not be modified.
4911 /* If we were handed a rooted logical name or spec, treat it like a
4912 * simple directory, so that
4913 * $ Define myroot dev:[dir.]
4914 * ... do_fileify_dirspec("myroot",buf,1) ...
4915 * does something useful.
4917 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4918 trndir[--dirlen] = '\0';
4919 trndir[dirlen-1] = ']';
4921 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4922 trndir[--dirlen] = '\0';
4923 trndir[dirlen-1] = '>';
4926 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4927 /* If we've got an explicit filename, we can just shuffle the string. */
4928 if (*(cp1+1)) hasfilename = 1;
4929 /* Similarly, we can just back up a level if we've got multiple levels
4930 of explicit directories in a VMS spec which ends with directories. */
4932 for (cp2 = cp1; cp2 > trndir; cp2--) {
4934 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4935 /* fix-me, can not scan EFS file specs backward like this */
4936 *cp2 = *cp1; *cp1 = '\0';
4941 if (*cp2 == '[' || *cp2 == '<') break;
4946 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4947 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4948 cp1 = strpbrk(trndir,"]:>");
4949 if (hasfilename || !cp1) { /* Unix-style path or filename */
4950 if (trndir[0] == '.') {
4951 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4952 PerlMem_free(trndir);
4953 PerlMem_free(vmsdir);
4954 return do_fileify_dirspec("[]",buf,ts,NULL);
4956 else if (trndir[1] == '.' &&
4957 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4958 PerlMem_free(trndir);
4959 PerlMem_free(vmsdir);
4960 return do_fileify_dirspec("[-]",buf,ts,NULL);
4963 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
4964 dirlen -= 1; /* to last element */
4965 lastdir = strrchr(trndir,'/');
4967 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4968 /* If we have "/." or "/..", VMSify it and let the VMS code
4969 * below expand it, rather than repeating the code to handle
4970 * relative components of a filespec here */
4972 if (*(cp1+2) == '.') cp1++;
4973 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4975 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
4976 PerlMem_free(trndir);
4977 PerlMem_free(vmsdir);
4980 if (strchr(vmsdir,'/') != NULL) {
4981 /* If do_tovmsspec() returned it, it must have VMS syntax
4982 * delimiters in it, so it's a mixed VMS/Unix spec. We take
4983 * the time to check this here only so we avoid a recursion
4984 * loop; otherwise, gigo.
4986 PerlMem_free(trndir);
4987 PerlMem_free(vmsdir);
4988 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
4991 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
4992 PerlMem_free(trndir);
4993 PerlMem_free(vmsdir);
4996 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
4997 PerlMem_free(trndir);
4998 PerlMem_free(vmsdir);
5002 } while ((cp1 = strstr(cp1,"/.")) != NULL);
5003 lastdir = strrchr(trndir,'/');
5005 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5007 /* Ditto for specs that end in an MFD -- let the VMS code
5008 * figure out whether it's a real device or a rooted logical. */
5010 /* This should not happen any more. Allowing the fake /000000
5011 * in a UNIX pathname causes all sorts of problems when trying
5012 * to run in UNIX emulation. So the VMS to UNIX conversions
5013 * now remove the fake /000000 directories.
5016 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5017 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5018 PerlMem_free(trndir);
5019 PerlMem_free(vmsdir);
5022 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5023 PerlMem_free(trndir);
5024 PerlMem_free(vmsdir);
5027 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5028 PerlMem_free(trndir);
5029 PerlMem_free(vmsdir);
5034 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5035 !(lastdir = cp1 = strrchr(trndir,']')) &&
5036 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5037 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
5040 /* For EFS or ODS-5 look for the last dot */
5041 if (decc_efs_charset) {
5042 cp2 = strrchr(cp1,'.');
5044 if (vms_process_case_tolerant) {
5045 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5046 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5047 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5048 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5049 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5050 (ver || *cp3)))))) {
5051 PerlMem_free(trndir);
5052 PerlMem_free(vmsdir);
5054 set_vaxc_errno(RMS$_DIR);
5059 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5060 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5061 !*(cp2+3) || *(cp2+3) != 'R' ||
5062 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5063 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5064 (ver || *cp3)))))) {
5065 PerlMem_free(trndir);
5066 PerlMem_free(vmsdir);
5068 set_vaxc_errno(RMS$_DIR);
5072 dirlen = cp2 - trndir;
5076 retlen = dirlen + 6;
5077 if (buf) retspec = buf;
5078 else if (ts) Newx(retspec,retlen+1,char);
5079 else retspec = __fileify_retbuf;
5080 memcpy(retspec,trndir,dirlen);
5081 retspec[dirlen] = '\0';
5083 /* We've picked up everything up to the directory file name.
5084 Now just add the type and version, and we're set. */
5085 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5086 strcat(retspec,".dir;1");
5088 strcat(retspec,".DIR;1");
5089 PerlMem_free(trndir);
5090 PerlMem_free(vmsdir);
5093 else { /* VMS-style directory spec */
5095 char *esa, term, *cp;
5096 unsigned long int sts, cmplen, haslower = 0;
5097 unsigned int nam_fnb;
5099 struct FAB dirfab = cc$rms_fab;
5100 rms_setup_nam(savnam);
5101 rms_setup_nam(dirnam);
5103 esa = PerlMem_malloc(VMS_MAXRSS + 1);
5104 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5105 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5106 rms_bind_fab_nam(dirfab, dirnam);
5107 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5108 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5109 #ifdef NAM$M_NO_SHORT_UPCASE
5110 if (decc_efs_case_preserve)
5111 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5114 for (cp = trndir; *cp; cp++)
5115 if (islower(*cp)) { haslower = 1; break; }
5116 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5117 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5118 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5119 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5123 PerlMem_free(trndir);
5124 PerlMem_free(vmsdir);
5126 set_vaxc_errno(dirfab.fab$l_sts);
5132 /* Does the file really exist? */
5133 if (sys$search(&dirfab)& STS$K_SUCCESS) {
5134 /* Yes; fake the fnb bits so we'll check type below */
5135 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5137 else { /* No; just work with potential name */
5138 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5141 fab_sts = dirfab.fab$l_sts;
5142 sts = rms_free_search_context(&dirfab);
5144 PerlMem_free(trndir);
5145 PerlMem_free(vmsdir);
5146 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
5151 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5152 cp1 = strchr(esa,']');
5153 if (!cp1) cp1 = strchr(esa,'>');
5154 if (cp1) { /* Should always be true */
5155 rms_nam_esll(dirnam) -= cp1 - esa - 1;
5156 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5159 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5160 /* Yep; check version while we're at it, if it's there. */
5161 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5162 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5163 /* Something other than .DIR[;1]. Bzzt. */
5164 sts = rms_free_search_context(&dirfab);
5166 PerlMem_free(trndir);
5167 PerlMem_free(vmsdir);
5169 set_vaxc_errno(RMS$_DIR);
5173 esa[rms_nam_esll(dirnam)] = '\0';
5174 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5175 /* They provided at least the name; we added the type, if necessary, */
5176 if (buf) retspec = buf; /* in sys$parse() */
5177 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5178 else retspec = __fileify_retbuf;
5179 strcpy(retspec,esa);
5180 sts = rms_free_search_context(&dirfab);
5181 PerlMem_free(trndir);
5183 PerlMem_free(vmsdir);
5186 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5187 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5189 rms_nam_esll(dirnam) -= 9;
5191 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5192 if (cp1 == NULL) { /* should never happen */
5193 sts = rms_free_search_context(&dirfab);
5194 PerlMem_free(trndir);
5196 PerlMem_free(vmsdir);
5201 retlen = strlen(esa);
5202 cp1 = strrchr(esa,'.');
5203 /* ODS-5 directory specifications can have extra "." in them. */
5204 /* Fix-me, can not scan EFS file specifications backwards */
5205 while (cp1 != NULL) {
5206 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5210 while ((cp1 > esa) && (*cp1 != '.'))
5217 if ((cp1) != NULL) {
5218 /* There's more than one directory in the path. Just roll back. */
5220 if (buf) retspec = buf;
5221 else if (ts) Newx(retspec,retlen+7,char);
5222 else retspec = __fileify_retbuf;
5223 strcpy(retspec,esa);
5226 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5227 /* Go back and expand rooted logical name */
5228 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5229 #ifdef NAM$M_NO_SHORT_UPCASE
5230 if (decc_efs_case_preserve)
5231 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5233 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5234 sts = rms_free_search_context(&dirfab);
5236 PerlMem_free(trndir);
5237 PerlMem_free(vmsdir);
5239 set_vaxc_errno(dirfab.fab$l_sts);
5242 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5243 if (buf) retspec = buf;
5244 else if (ts) Newx(retspec,retlen+16,char);
5245 else retspec = __fileify_retbuf;
5246 cp1 = strstr(esa,"][");
5247 if (!cp1) cp1 = strstr(esa,"]<");
5249 memcpy(retspec,esa,dirlen);
5250 if (!strncmp(cp1+2,"000000]",7)) {
5251 retspec[dirlen-1] = '\0';
5252 /* fix-me Not full ODS-5, just extra dots in directories for now */
5253 cp1 = retspec + dirlen - 1;
5254 while (cp1 > retspec)
5259 if (*(cp1-1) != '^')
5264 if (*cp1 == '.') *cp1 = ']';
5266 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5267 memmove(cp1+1,"000000]",7);
5271 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5272 retspec[retlen] = '\0';
5273 /* Convert last '.' to ']' */
5274 cp1 = retspec+retlen-1;
5275 while (*cp != '[') {
5278 /* Do not trip on extra dots in ODS-5 directories */
5279 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5283 if (*cp1 == '.') *cp1 = ']';
5285 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5286 memmove(cp1+1,"000000]",7);
5290 else { /* This is a top-level dir. Add the MFD to the path. */
5291 if (buf) retspec = buf;
5292 else if (ts) Newx(retspec,retlen+16,char);
5293 else retspec = __fileify_retbuf;
5296 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5297 strcpy(cp2,":[000000]");
5302 sts = rms_free_search_context(&dirfab);
5303 /* We've set up the string up through the filename. Add the
5304 type and version, and we're done. */
5305 strcat(retspec,".DIR;1");
5307 /* $PARSE may have upcased filespec, so convert output to lower
5308 * case if input contained any lowercase characters. */
5309 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5310 PerlMem_free(trndir);
5312 PerlMem_free(vmsdir);
5315 } /* end of do_fileify_dirspec() */
5317 /* External entry points */
5318 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5319 { return do_fileify_dirspec(dir,buf,0,NULL); }
5320 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5321 { return do_fileify_dirspec(dir,buf,1,NULL); }
5322 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5323 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5324 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5325 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5327 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5328 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5330 static char __pathify_retbuf[VMS_MAXRSS];
5331 unsigned long int retlen;
5332 char *retpath, *cp1, *cp2, *trndir;
5333 unsigned short int trnlnm_iter_count;
5336 if (utf8_fl != NULL)
5339 if (!dir || !*dir) {
5340 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5343 trndir = PerlMem_malloc(VMS_MAXRSS);
5344 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5345 if (*dir) strcpy(trndir,dir);
5346 else getcwd(trndir,VMS_MAXRSS - 1);
5348 trnlnm_iter_count = 0;
5349 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5350 && my_trnlnm(trndir,trndir,0)) {
5351 trnlnm_iter_count++;
5352 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5353 trnlen = strlen(trndir);
5355 /* Trap simple rooted lnms, and return lnm:[000000] */
5356 if (!strcmp(trndir+trnlen-2,".]")) {
5357 if (buf) retpath = buf;
5358 else if (ts) Newx(retpath,strlen(dir)+10,char);
5359 else retpath = __pathify_retbuf;
5360 strcpy(retpath,dir);
5361 strcat(retpath,":[000000]");
5362 PerlMem_free(trndir);
5367 /* At this point we do not work with *dir, but the copy in
5368 * *trndir that is modifiable.
5371 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5372 if (*trndir == '.' && (*(trndir+1) == '\0' ||
5373 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5374 retlen = 2 + (*(trndir+1) != '\0');
5376 if ( !(cp1 = strrchr(trndir,'/')) &&
5377 !(cp1 = strrchr(trndir,']')) &&
5378 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5379 if ((cp2 = strchr(cp1,'.')) != NULL &&
5380 (*(cp2-1) != '/' || /* Trailing '.', '..', */
5381 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
5382 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5383 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5386 /* For EFS or ODS-5 look for the last dot */
5387 if (decc_efs_charset) {
5388 cp2 = strrchr(cp1,'.');
5390 if (vms_process_case_tolerant) {
5391 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5392 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5393 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5394 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5395 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5396 (ver || *cp3)))))) {
5397 PerlMem_free(trndir);
5399 set_vaxc_errno(RMS$_DIR);
5404 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5405 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5406 !*(cp2+3) || *(cp2+3) != 'R' ||
5407 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5408 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5409 (ver || *cp3)))))) {
5410 PerlMem_free(trndir);
5412 set_vaxc_errno(RMS$_DIR);
5416 retlen = cp2 - trndir + 1;
5418 else { /* No file type present. Treat the filename as a directory. */
5419 retlen = strlen(trndir) + 1;
5422 if (buf) retpath = buf;
5423 else if (ts) Newx(retpath,retlen+1,char);
5424 else retpath = __pathify_retbuf;
5425 strncpy(retpath, trndir, retlen-1);
5426 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5427 retpath[retlen-1] = '/'; /* with '/', add it. */
5428 retpath[retlen] = '\0';
5430 else retpath[retlen-1] = '\0';
5432 else { /* VMS-style directory spec */
5434 unsigned long int sts, cmplen, haslower;
5435 struct FAB dirfab = cc$rms_fab;
5437 rms_setup_nam(savnam);
5438 rms_setup_nam(dirnam);
5440 /* If we've got an explicit filename, we can just shuffle the string. */
5441 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5442 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
5443 if ((cp2 = strchr(cp1,'.')) != NULL) {
5445 if (vms_process_case_tolerant) {
5446 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5447 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5448 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5449 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5450 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5451 (ver || *cp3)))))) {
5452 PerlMem_free(trndir);
5454 set_vaxc_errno(RMS$_DIR);
5459 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5460 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5461 !*(cp2+3) || *(cp2+3) != 'R' ||
5462 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5463 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5464 (ver || *cp3)))))) {
5465 PerlMem_free(trndir);
5467 set_vaxc_errno(RMS$_DIR);
5472 else { /* No file type, so just draw name into directory part */
5473 for (cp2 = cp1; *cp2; cp2++) ;
5476 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5478 /* We've now got a VMS 'path'; fall through */
5481 dirlen = strlen(trndir);
5482 if (trndir[dirlen-1] == ']' ||
5483 trndir[dirlen-1] == '>' ||
5484 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5485 if (buf) retpath = buf;
5486 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5487 else retpath = __pathify_retbuf;
5488 strcpy(retpath,trndir);
5489 PerlMem_free(trndir);
5492 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5493 esa = PerlMem_malloc(VMS_MAXRSS);
5494 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5495 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5496 rms_bind_fab_nam(dirfab, dirnam);
5497 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5498 #ifdef NAM$M_NO_SHORT_UPCASE
5499 if (decc_efs_case_preserve)
5500 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5503 for (cp = trndir; *cp; cp++)
5504 if (islower(*cp)) { haslower = 1; break; }
5506 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5507 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5508 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5509 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5512 PerlMem_free(trndir);
5515 set_vaxc_errno(dirfab.fab$l_sts);
5521 /* Does the file really exist? */
5522 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5523 if (dirfab.fab$l_sts != RMS$_FNF) {
5525 sts1 = rms_free_search_context(&dirfab);
5526 PerlMem_free(trndir);
5529 set_vaxc_errno(dirfab.fab$l_sts);
5532 dirnam = savnam; /* No; just work with potential name */
5535 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5536 /* Yep; check version while we're at it, if it's there. */
5537 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5538 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5540 /* Something other than .DIR[;1]. Bzzt. */
5541 sts2 = rms_free_search_context(&dirfab);
5542 PerlMem_free(trndir);
5545 set_vaxc_errno(RMS$_DIR);
5549 /* OK, the type was fine. Now pull any file name into the
5551 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5553 cp1 = strrchr(esa,'>');
5554 *(rms_nam_typel(dirnam)) = '>';
5557 *(rms_nam_typel(dirnam) + 1) = '\0';
5558 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5559 if (buf) retpath = buf;
5560 else if (ts) Newx(retpath,retlen,char);
5561 else retpath = __pathify_retbuf;
5562 strcpy(retpath,esa);
5564 sts = rms_free_search_context(&dirfab);
5565 /* $PARSE may have upcased filespec, so convert output to lower
5566 * case if input contained any lowercase characters. */
5567 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5570 PerlMem_free(trndir);
5572 } /* end of do_pathify_dirspec() */
5574 /* External entry points */
5575 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5576 { return do_pathify_dirspec(dir,buf,0,NULL); }
5577 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5578 { return do_pathify_dirspec(dir,buf,1,NULL); }
5579 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5580 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5581 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5582 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5584 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5585 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5587 static char __tounixspec_retbuf[VMS_MAXRSS];
5588 char *dirend, *rslt, *cp1, *cp3, *tmp;
5590 int devlen, dirlen, retlen = VMS_MAXRSS;
5591 int expand = 1; /* guarantee room for leading and trailing slashes */
5592 unsigned short int trnlnm_iter_count;
5594 if (utf8_fl != NULL)
5597 if (spec == NULL) return NULL;
5598 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5599 if (buf) rslt = buf;
5601 Newx(rslt, VMS_MAXRSS, char);
5603 else rslt = __tounixspec_retbuf;
5605 /* New VMS specific format needs translation
5606 * glob passes filenames with trailing '\n' and expects this preserved.
5608 if (decc_posix_compliant_pathnames) {
5609 if (strncmp(spec, "\"^UP^", 5) == 0) {
5615 tunix = PerlMem_malloc(VMS_MAXRSS);
5616 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5617 strcpy(tunix, spec);
5618 tunix_len = strlen(tunix);
5620 if (tunix[tunix_len - 1] == '\n') {
5621 tunix[tunix_len - 1] = '\"';
5622 tunix[tunix_len] = '\0';
5626 uspec = decc$translate_vms(tunix);
5627 PerlMem_free(tunix);
5628 if ((int)uspec > 0) {
5634 /* If we can not translate it, makemaker wants as-is */
5642 cmp_rslt = 0; /* Presume VMS */
5643 cp1 = strchr(spec, '/');
5647 /* Look for EFS ^/ */
5648 if (decc_efs_charset) {
5649 while (cp1 != NULL) {
5652 /* Found illegal VMS, assume UNIX */
5657 cp1 = strchr(cp1, '/');
5661 /* Look for "." and ".." */
5662 if (decc_filename_unix_report) {
5663 if (spec[0] == '.') {
5664 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5668 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5674 /* This is already UNIX or at least nothing VMS understands */
5682 dirend = strrchr(spec,']');
5683 if (dirend == NULL) dirend = strrchr(spec,'>');
5684 if (dirend == NULL) dirend = strchr(spec,':');
5685 if (dirend == NULL) {
5690 /* Special case 1 - sys$posix_root = / */
5691 #if __CRTL_VER >= 70000000
5692 if (!decc_disable_posix_root) {
5693 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5701 /* Special case 2 - Convert NLA0: to /dev/null */
5702 #if __CRTL_VER < 70000000
5703 cmp_rslt = strncmp(spec,"NLA0:", 5);
5705 cmp_rslt = strncmp(spec,"nla0:", 5);
5707 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5709 if (cmp_rslt == 0) {
5710 strcpy(rslt, "/dev/null");
5713 if (spec[6] != '\0') {
5720 /* Also handle special case "SYS$SCRATCH:" */
5721 #if __CRTL_VER < 70000000
5722 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5724 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5726 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5728 tmp = PerlMem_malloc(VMS_MAXRSS);
5729 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5730 if (cmp_rslt == 0) {
5733 islnm = my_trnlnm(tmp, "TMP", 0);
5735 strcpy(rslt, "/tmp");
5738 if (spec[12] != '\0') {
5746 if (*cp2 != '[' && *cp2 != '<') {
5749 else { /* the VMS spec begins with directories */
5751 if (*cp2 == ']' || *cp2 == '>') {
5752 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5756 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5757 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5758 if (ts) Safefree(rslt);
5762 trnlnm_iter_count = 0;
5765 while (*cp3 != ':' && *cp3) cp3++;
5767 if (strchr(cp3,']') != NULL) break;
5768 trnlnm_iter_count++;
5769 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5770 } while (vmstrnenv(tmp,tmp,0,fildev,0));
5772 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5773 retlen = devlen + dirlen;
5774 Renew(rslt,retlen+1+2*expand,char);
5780 *(cp1++) = *(cp3++);
5781 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5783 return NULL; /* No room */
5788 if ((*cp2 == '^')) {
5789 /* EFS file escape, pass the next character as is */
5790 /* Fix me: HEX encoding for UNICODE not implemented */
5793 else if ( *cp2 == '.') {
5794 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5795 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5802 for (; cp2 <= dirend; cp2++) {
5803 if ((*cp2 == '^')) {
5804 /* EFS file escape, pass the next character as is */
5805 /* Fix me: HEX encoding for UNICODE not implemented */
5811 if (*(cp2+1) == '[') cp2++;
5813 else if (*cp2 == ']' || *cp2 == '>') {
5814 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5816 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5818 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5819 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5820 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5821 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5822 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5824 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5825 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5829 else if (*cp2 == '-') {
5830 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5831 while (*cp2 == '-') {
5833 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5835 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5836 if (ts) Safefree(rslt); /* filespecs like */
5837 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
5841 else *(cp1++) = *cp2;
5843 else *(cp1++) = *cp2;
5845 while (*cp2) *(cp1++) = *(cp2++);
5848 /* This still leaves /000000/ when working with a
5849 * VMS device root or concealed root.
5855 ulen = strlen(rslt);
5857 /* Get rid of "000000/ in rooted filespecs */
5859 zeros = strstr(rslt, "/000000/");
5860 if (zeros != NULL) {
5862 mlen = ulen - (zeros - rslt) - 7;
5863 memmove(zeros, &zeros[7], mlen);
5872 } /* end of do_tounixspec() */
5874 /* External entry points */
5875 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
5876 { return do_tounixspec(spec,buf,0, NULL); }
5877 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
5878 { return do_tounixspec(spec,buf,1, NULL); }
5879 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
5880 { return do_tounixspec(spec,buf,0, utf8_fl); }
5881 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
5882 { return do_tounixspec(spec,buf,1, utf8_fl); }
5884 #if __CRTL_VER >= 70200000 && !defined(__VAX)
5887 This procedure is used to identify if a path is based in either
5888 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
5889 it returns the OpenVMS format directory for it.
5891 It is expecting specifications of only '/' or '/xxxx/'
5893 If a posix root does not exist, or 'xxxx' is not a directory
5894 in the posix root, it returns a failure.
5896 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
5898 It is used only internally by posix_to_vmsspec_hardway().
5901 static int posix_root_to_vms
5902 (char *vmspath, int vmspath_len,
5903 const char *unixpath,
5904 const int * utf8_fl) {
5906 struct FAB myfab = cc$rms_fab;
5907 struct NAML mynam = cc$rms_naml;
5908 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5909 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5916 unixlen = strlen(unixpath);
5922 #if __CRTL_VER >= 80200000
5923 /* If not a posix spec already, convert it */
5924 if (decc_posix_compliant_pathnames) {
5925 if (strncmp(unixpath,"\"^UP^",5) != 0) {
5926 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5929 /* This is already a VMS specification, no conversion */
5931 strncpy(vmspath,unixpath, vmspath_len);
5940 /* Check to see if this is under the POSIX root */
5941 if (decc_disable_posix_root) {
5945 /* Skip leading / */
5946 if (unixpath[0] == '/') {
5952 strcpy(vmspath,"SYS$POSIX_ROOT:");
5954 /* If this is only the / , or blank, then... */
5955 if (unixpath[0] == '\0') {
5956 /* by definition, this is the answer */
5960 /* Need to look up a directory */
5964 /* Copy and add '^' escape characters as needed */
5967 while (unixpath[i] != 0) {
5970 j += copy_expand_unix_filename_escape
5971 (&vmspath[j], &unixpath[i], &k, utf8_fl);
5975 path_len = strlen(vmspath);
5976 if (vmspath[path_len - 1] == '/')
5978 vmspath[path_len] = ']';
5980 vmspath[path_len] = '\0';
5983 vmspath[vmspath_len] = 0;
5984 if (unixpath[unixlen - 1] == '/')
5986 esa = PerlMem_malloc(VMS_MAXRSS);
5987 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5988 myfab.fab$l_fna = vmspath;
5989 myfab.fab$b_fns = strlen(vmspath);
5990 myfab.fab$l_naml = &mynam;
5991 mynam.naml$l_esa = NULL;
5992 mynam.naml$b_ess = 0;
5993 mynam.naml$l_long_expand = esa;
5994 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5995 mynam.naml$l_rsa = NULL;
5996 mynam.naml$b_rss = 0;
5997 if (decc_efs_case_preserve)
5998 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5999 #ifdef NAML$M_OPEN_SPECIAL
6000 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6003 /* Set up the remaining naml fields */
6004 sts = sys$parse(&myfab);
6006 /* It failed! Try again as a UNIX filespec */
6012 /* get the Device ID and the FID */
6013 sts = sys$search(&myfab);
6014 /* on any failure, returned the POSIX ^UP^ filespec */
6019 specdsc.dsc$a_pointer = vmspath;
6020 specdsc.dsc$w_length = vmspath_len;
6022 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6023 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6024 sts = lib$fid_to_name
6025 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6027 /* on any failure, returned the POSIX ^UP^ filespec */
6029 /* This can happen if user does not have permission to read directories */
6030 if (strncmp(unixpath,"\"^UP^",5) != 0)
6031 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6033 strcpy(vmspath, unixpath);
6036 vmspath[specdsc.dsc$w_length] = 0;
6038 /* Are we expecting a directory? */
6039 if (dir_flag != 0) {
6045 i = specdsc.dsc$w_length - 1;
6049 /* Version must be '1' */
6050 if (vmspath[i--] != '1')
6052 /* Version delimiter is one of ".;" */
6053 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6056 if (vmspath[i--] != 'R')
6058 if (vmspath[i--] != 'I')
6060 if (vmspath[i--] != 'D')
6062 if (vmspath[i--] != '.')
6064 eptr = &vmspath[i+1];
6066 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6067 if (vmspath[i-1] != '^') {
6075 /* Get rid of 6 imaginary zero directory filename */
6076 vmspath[i+1] = '\0';
6080 if (vmspath[i] == '0')
6094 /* /dev/mumble needs to be handled special.
6095 /dev/null becomes NLA0:, And there is the potential for other stuff
6096 like /dev/tty which may need to be mapped to something.
6100 slash_dev_special_to_vms
6101 (const char * unixptr,
6111 nextslash = strchr(unixptr, '/');
6112 len = strlen(unixptr);
6113 if (nextslash != NULL)
6114 len = nextslash - unixptr;
6115 cmp = strncmp("null", unixptr, 5);
6117 if (vmspath_len >= 6) {
6118 strcpy(vmspath, "_NLA0:");
6125 /* The built in routines do not understand perl's special needs, so
6126 doing a manual conversion from UNIX to VMS
6128 If the utf8_fl is not null and points to a non-zero value, then
6129 treat 8 bit characters as UTF-8.
6131 The sequence starting with '$(' and ending with ')' will be passed
6132 through with out interpretation instead of being escaped.
6135 static int posix_to_vmsspec_hardway
6136 (char *vmspath, int vmspath_len,
6137 const char *unixpath,
6142 const char *unixptr;
6143 const char *unixend;
6145 const char *lastslash;
6146 const char *lastdot;
6152 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6153 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6155 if (utf8_fl != NULL)
6161 /* Ignore leading "/" characters */
6162 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6165 unixlen = strlen(unixptr);
6167 /* Do nothing with blank paths */
6174 /* This could have a "^UP^ on the front */
6175 if (strncmp(unixptr,"\"^UP^",5) == 0) {
6181 lastslash = strrchr(unixptr,'/');
6182 lastdot = strrchr(unixptr,'.');
6183 unixend = strrchr(unixptr,'\"');
6184 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6185 unixend = unixptr + unixlen;
6188 /* last dot is last dot or past end of string */
6189 if (lastdot == NULL)
6190 lastdot = unixptr + unixlen;
6192 /* if no directories, set last slash to beginning of string */
6193 if (lastslash == NULL) {
6194 lastslash = unixptr;
6197 /* Watch out for trailing "." after last slash, still a directory */
6198 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6199 lastslash = unixptr + unixlen;
6202 /* Watch out for traiing ".." after last slash, still a directory */
6203 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6204 lastslash = unixptr + unixlen;
6207 /* dots in directories are aways escaped */
6208 if (lastdot < lastslash)
6209 lastdot = unixptr + unixlen;
6212 /* if (unixptr < lastslash) then we are in a directory */
6219 /* Start with the UNIX path */
6220 if (*unixptr != '/') {
6221 /* relative paths */
6223 /* If allowing logical names on relative pathnames, then handle here */
6224 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6225 !decc_posix_compliant_pathnames) {
6231 /* Find the next slash */
6232 nextslash = strchr(unixptr,'/');
6234 esa = PerlMem_malloc(vmspath_len);
6235 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6237 trn = PerlMem_malloc(VMS_MAXRSS);
6238 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6240 if (nextslash != NULL) {
6242 seg_len = nextslash - unixptr;
6243 strncpy(esa, unixptr, seg_len);
6247 strcpy(esa, unixptr);
6248 seg_len = strlen(unixptr);
6250 /* trnlnm(section) */
6251 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6254 /* Now fix up the directory */
6256 /* Split up the path to find the components */
6257 sts = vms_split_path
6276 /* A logical name must be a directory or the full
6277 specification. It is only a full specification if
6278 it is the only component */
6279 if ((unixptr[seg_len] == '\0') ||
6280 (unixptr[seg_len+1] == '\0')) {
6282 /* Is a directory being required? */
6283 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6284 /* Not a logical name */
6289 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6290 /* This must be a directory */
6291 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6292 strcpy(vmsptr, esa);
6293 vmslen=strlen(vmsptr);
6294 vmsptr[vmslen] = ':';
6296 vmsptr[vmslen] = '\0';
6304 /* must be dev/directory - ignore version */
6305 if ((n_len + e_len) != 0)
6308 /* transfer the volume */
6309 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6310 strncpy(vmsptr, v_spec, v_len);
6316 /* unroot the rooted directory */
6317 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6319 r_spec[r_len - 1] = ']';
6321 /* This should not be there, but nothing is perfect */
6323 cmp = strcmp(&r_spec[1], "000000.");
6333 strncpy(vmsptr, r_spec, r_len);
6339 /* Bring over the directory. */
6341 ((d_len + vmslen) < vmspath_len)) {
6343 d_spec[d_len - 1] = ']';
6345 cmp = strcmp(&d_spec[1], "000000.");
6356 /* Remove the redundant root */
6364 strncpy(vmsptr, d_spec, d_len);
6378 if (lastslash > unixptr) {
6381 /* skip leading ./ */
6383 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6389 /* Are we still in a directory? */
6390 if (unixptr <= lastslash) {
6395 /* if not backing up, then it is relative forward. */
6396 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6397 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6405 /* Perl wants an empty directory here to tell the difference
6406 * between a DCL commmand and a filename
6415 /* Handle two special files . and .. */
6416 if (unixptr[0] == '.') {
6417 if (&unixptr[1] == unixend) {
6424 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6435 else { /* Absolute PATH handling */
6439 /* Need to find out where root is */
6441 /* In theory, this procedure should never get an absolute POSIX pathname
6442 * that can not be found on the POSIX root.
6443 * In practice, that can not be relied on, and things will show up
6444 * here that are a VMS device name or concealed logical name instead.
6445 * So to make things work, this procedure must be tolerant.
6447 esa = PerlMem_malloc(vmspath_len);
6448 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6451 nextslash = strchr(&unixptr[1],'/');
6453 if (nextslash != NULL) {
6455 seg_len = nextslash - &unixptr[1];
6456 strncpy(vmspath, unixptr, seg_len + 1);
6457 vmspath[seg_len+1] = 0;
6460 cmp = strncmp(vmspath, "dev", 4);
6462 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6463 if (sts = SS$_NORMAL)
6467 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6470 if ($VMS_STATUS_SUCCESS(sts)) {
6471 /* This is verified to be a real path */
6473 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6474 if ($VMS_STATUS_SUCCESS(sts)) {
6475 strcpy(vmspath, esa);
6476 vmslen = strlen(vmspath);
6477 vmsptr = vmspath + vmslen;
6479 if (unixptr < lastslash) {
6488 cmp = strcmp(rptr,"000000.");
6493 } /* removing 6 zeros */
6494 } /* vmslen < 7, no 6 zeros possible */
6495 } /* Not in a directory */
6496 } /* Posix root found */
6498 /* No posix root, fall back to default directory */
6499 strcpy(vmspath, "SYS$DISK:[");
6500 vmsptr = &vmspath[10];
6502 if (unixptr > lastslash) {
6511 } /* end of verified real path handling */
6516 /* Ok, we have a device or a concealed root that is not in POSIX
6517 * or we have garbage. Make the best of it.
6520 /* Posix to VMS destroyed this, so copy it again */
6521 strncpy(vmspath, &unixptr[1], seg_len);
6522 vmspath[seg_len] = 0;
6524 vmsptr = &vmsptr[vmslen];
6527 /* Now do we need to add the fake 6 zero directory to it? */
6529 if ((*lastslash == '/') && (nextslash < lastslash)) {
6530 /* No there is another directory */
6537 /* now we have foo:bar or foo:[000000]bar to decide from */
6538 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6540 if (!islnm && !decc_posix_compliant_pathnames) {
6542 cmp = strncmp("bin", vmspath, 4);
6544 /* bin => SYS$SYSTEM: */
6545 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6548 /* tmp => SYS$SCRATCH: */
6549 cmp = strncmp("tmp", vmspath, 4);
6551 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6556 trnend = islnm ? islnm - 1 : 0;
6558 /* if this was a logical name, ']' or '>' must be present */
6559 /* if not a logical name, then assume a device and hope. */
6560 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6562 /* if log name and trailing '.' then rooted - treat as device */
6563 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6565 /* Fix me, if not a logical name, a device lookup should be
6566 * done to see if the device is file structured. If the device
6567 * is not file structured, the 6 zeros should not be put on.
6569 * As it is, perl is occasionally looking for dev:[000000]tty.
6570 * which looks a little strange.
6572 * Not that easy to detect as "/dev" may be file structured with
6573 * special device files.
6576 if ((add_6zero == 0) && (*nextslash == '/') &&
6577 (&nextslash[1] == unixend)) {
6578 /* No real directory present */
6583 /* Put the device delimiter on */
6586 unixptr = nextslash;
6589 /* Start directory if needed */
6590 if (!islnm || add_6zero) {
6596 /* add fake 000000] if needed */
6609 } /* non-POSIX translation */
6611 } /* End of relative/absolute path handling */
6613 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6620 if (dir_start != 0) {
6622 /* First characters in a directory are handled special */
6623 while ((*unixptr == '/') ||
6624 ((*unixptr == '.') &&
6625 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6626 (&unixptr[1]==unixend)))) {
6631 /* Skip redundant / in specification */
6632 while ((*unixptr == '/') && (dir_start != 0)) {
6635 if (unixptr == lastslash)
6638 if (unixptr == lastslash)
6641 /* Skip redundant ./ characters */
6642 while ((*unixptr == '.') &&
6643 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6646 if (unixptr == lastslash)
6648 if (*unixptr == '/')
6651 if (unixptr == lastslash)
6654 /* Skip redundant ../ characters */
6655 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6656 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6657 /* Set the backing up flag */
6663 unixptr++; /* first . */
6664 unixptr++; /* second . */
6665 if (unixptr == lastslash)
6667 if (*unixptr == '/') /* The slash */
6670 if (unixptr == lastslash)
6673 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6674 /* Not needed when VMS is pretending to be UNIX. */
6676 /* Is this loop stuck because of too many dots? */
6677 if (loop_flag == 0) {
6678 /* Exit the loop and pass the rest through */
6683 /* Are we done with directories yet? */
6684 if (unixptr >= lastslash) {
6686 /* Watch out for trailing dots */
6695 if (*unixptr == '/')
6699 /* Have we stopped backing up? */
6704 /* dir_start continues to be = 1 */
6706 if (*unixptr == '-') {
6708 *vmsptr++ = *unixptr++;
6712 /* Now are we done with directories yet? */
6713 if (unixptr >= lastslash) {
6715 /* Watch out for trailing dots */
6731 if (unixptr >= unixend)
6734 /* Normal characters - More EFS work probably needed */
6740 /* remove multiple / */
6741 while (unixptr[1] == '/') {
6744 if (unixptr == lastslash) {
6745 /* Watch out for trailing dots */
6757 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6758 /* Not needed when VMS is pretending to be UNIX. */
6762 if (unixptr != unixend)
6767 if ((unixptr < lastdot) || (unixptr < lastslash) ||
6768 (&unixptr[1] == unixend)) {
6774 /* trailing dot ==> '^..' on VMS */
6775 if (unixptr == unixend) {
6783 *vmsptr++ = *unixptr++;
6787 if (quoted && (&unixptr[1] == unixend)) {
6791 in_cnt = copy_expand_unix_filename_escape
6792 (vmsptr, unixptr, &out_cnt, utf8_fl);
6802 in_cnt = copy_expand_unix_filename_escape
6803 (vmsptr, unixptr, &out_cnt, utf8_fl);
6810 /* Make sure directory is closed */
6811 if (unixptr == lastslash) {
6813 vmsptr2 = vmsptr - 1;
6815 if (*vmsptr2 != ']') {
6818 /* directories do not end in a dot bracket */
6819 if (*vmsptr2 == '.') {
6823 if (*vmsptr2 != '^') {
6824 vmsptr--; /* back up over the dot */
6832 /* Add a trailing dot if a file with no extension */
6833 vmsptr2 = vmsptr - 1;
6835 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6836 (*vmsptr2 != ')') && (*lastdot != '.')) {
6847 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
6848 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
6853 /* If a UTF8 flag is being passed, honor it */
6855 if (utf8_fl != NULL) {
6856 utf8_flag = *utf8_fl;
6861 /* If there is a possibility of UTF8, then if any UTF8 characters
6862 are present, then they must be converted to VTF-7
6864 result = strcpy(rslt, path); /* FIX-ME */
6867 result = strcpy(rslt, path);
6873 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
6874 static char *mp_do_tovmsspec
6875 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
6876 static char __tovmsspec_retbuf[VMS_MAXRSS];
6877 char *rslt, *dirend;
6882 unsigned long int infront = 0, hasdir = 1;
6885 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6886 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6888 if (path == NULL) return NULL;
6889 rslt_len = VMS_MAXRSS-1;
6890 if (buf) rslt = buf;
6891 else if (ts) Newx(rslt, VMS_MAXRSS, char);
6892 else rslt = __tovmsspec_retbuf;
6894 /* '.' and '..' are "[]" and "[-]" for a quick check */
6895 if (path[0] == '.') {
6896 if (path[1] == '\0') {
6898 if (utf8_flag != NULL)
6903 if (path[1] == '.' && path[2] == '\0') {
6905 if (utf8_flag != NULL)
6912 /* Posix specifications are now a native VMS format */
6913 /*--------------------------------------------------*/
6914 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6915 if (decc_posix_compliant_pathnames) {
6916 if (strncmp(path,"\"^UP^",5) == 0) {
6917 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
6923 /* This is really the only way to see if this is already in VMS format */
6924 sts = vms_split_path
6939 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
6940 replacement, because the above parse just took care of most of
6941 what is needed to do vmspath when the specification is already
6944 And if it is not already, it is easier to do the conversion as
6945 part of this routine than to call this routine and then work on
6949 /* If VMS punctuation was found, it is already VMS format */
6950 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
6951 if (utf8_flag != NULL)
6956 /* Now, what to do with trailing "." cases where there is no
6957 extension? If this is a UNIX specification, and EFS characters
6958 are enabled, then the trailing "." should be converted to a "^.".
6959 But if this was already a VMS specification, then it should be
6962 So in the case of ambiguity, leave the specification alone.
6966 /* If there is a possibility of UTF8, then if any UTF8 characters
6967 are present, then they must be converted to VTF-7
6969 if (utf8_flag != NULL)
6975 dirend = strrchr(path,'/');
6977 if (dirend == NULL) {
6978 /* If we get here with no UNIX directory delimiters, then this is
6979 not a complete file specification, either garbage a UNIX glob
6980 specification that can not be converted to a VMS wildcard, or
6981 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
6982 so apparently other programs expect this also.
6984 utf8 flag setting needs to be preserved.
6990 /* If POSIX mode active, handle the conversion */
6991 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6992 if (decc_efs_charset) {
6993 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
6998 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
6999 if (!*(dirend+2)) dirend +=2;
7000 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7001 if (decc_efs_charset == 0) {
7002 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7008 lastdot = strrchr(cp2,'.');
7014 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7016 if (decc_disable_posix_root) {
7017 strcpy(rslt,"sys$disk:[000000]");
7020 strcpy(rslt,"sys$posix_root:[000000]");
7022 if (utf8_flag != NULL)
7026 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7028 trndev = PerlMem_malloc(VMS_MAXRSS);
7029 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7030 islnm = my_trnlnm(rslt,trndev,0);
7032 /* DECC special handling */
7034 if (strcmp(rslt,"bin") == 0) {
7035 strcpy(rslt,"sys$system");
7038 islnm = my_trnlnm(rslt,trndev,0);
7040 else if (strcmp(rslt,"tmp") == 0) {
7041 strcpy(rslt,"sys$scratch");
7044 islnm = my_trnlnm(rslt,trndev,0);
7046 else if (!decc_disable_posix_root) {
7047 strcpy(rslt, "sys$posix_root");
7051 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7052 islnm = my_trnlnm(rslt,trndev,0);
7054 else if (strcmp(rslt,"dev") == 0) {
7055 if (strncmp(cp2,"/null", 5) == 0) {
7056 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7057 strcpy(rslt,"NLA0");
7061 islnm = my_trnlnm(rslt,trndev,0);
7067 trnend = islnm ? strlen(trndev) - 1 : 0;
7068 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7069 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7070 /* If the first element of the path is a logical name, determine
7071 * whether it has to be translated so we can add more directories. */
7072 if (!islnm || rooted) {
7075 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7079 if (cp2 != dirend) {
7080 strcpy(rslt,trndev);
7081 cp1 = rslt + trnend;
7088 if (decc_disable_posix_root) {
7094 PerlMem_free(trndev);
7099 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7100 cp2 += 2; /* skip over "./" - it's redundant */
7101 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
7103 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7104 *(cp1++) = '-'; /* "../" --> "-" */
7107 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7108 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7109 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7110 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7113 else if ((cp2 != lastdot) || (lastdot < dirend)) {
7114 /* Escape the extra dots in EFS file specifications */
7117 if (cp2 > dirend) cp2 = dirend;
7119 else *(cp1++) = '.';
7121 for (; cp2 < dirend; cp2++) {
7123 if (*(cp2-1) == '/') continue;
7124 if (*(cp1-1) != '.') *(cp1++) = '.';
7127 else if (!infront && *cp2 == '.') {
7128 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7129 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
7130 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7131 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7132 else if (*(cp1-2) == '[') *(cp1-1) = '-';
7133 else { /* back up over previous directory name */
7135 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7136 if (*(cp1-1) == '[') {
7137 memcpy(cp1,"000000.",7);
7142 if (cp2 == dirend) break;
7144 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7145 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7146 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7147 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7149 *(cp1++) = '.'; /* Simulate trailing '/' */
7150 cp2 += 2; /* for loop will incr this to == dirend */
7152 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
7155 if (decc_efs_charset == 0)
7156 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
7158 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
7164 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
7166 if (decc_efs_charset == 0)
7173 else *(cp1++) = *cp2;
7177 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7178 if (hasdir) *(cp1++) = ']';
7179 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
7180 /* fixme for ODS5 */
7187 if (decc_efs_charset == 0)
7198 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7199 decc_readdir_dropdotnotype) {
7204 /* trailing dot ==> '^..' on VMS */
7211 *(cp1++) = *(cp2++);
7216 /* This could be a macro to be passed through */
7217 *(cp1++) = *(cp2++);
7219 const char * save_cp2;
7223 /* paranoid check */
7229 *(cp1++) = *(cp2++);
7230 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7231 *(cp1++) = *(cp2++);
7232 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7233 *(cp1++) = *(cp2++);
7236 *(cp1++) = *(cp2++);
7240 if (is_macro == 0) {
7241 /* Not really a macro - never mind */
7271 *(cp1++) = *(cp2++);
7274 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7275 * which is wrong. UNIX notation should be ".dir." unless
7276 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7277 * changing this behavior could break more things at this time.
7278 * efs character set effectively does not allow "." to be a version
7279 * delimiter as a further complication about changing this.
7281 if (decc_filename_unix_report != 0) {
7284 *(cp1++) = *(cp2++);
7287 *(cp1++) = *(cp2++);
7290 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7294 /* Fix me for "^]", but that requires making sure that you do
7295 * not back up past the start of the filename
7297 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7302 if (utf8_flag != NULL)
7306 } /* end of do_tovmsspec() */
7308 /* External entry points */
7309 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7310 { return do_tovmsspec(path,buf,0,NULL); }
7311 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7312 { return do_tovmsspec(path,buf,1,NULL); }
7313 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7314 { return do_tovmsspec(path,buf,0,utf8_fl); }
7315 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7316 { return do_tovmsspec(path,buf,1,utf8_fl); }
7318 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7319 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7320 static char __tovmspath_retbuf[VMS_MAXRSS];
7322 char *pathified, *vmsified, *cp;
7324 if (path == NULL) return NULL;
7325 pathified = PerlMem_malloc(VMS_MAXRSS);
7326 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7327 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7328 PerlMem_free(pathified);
7334 Newx(vmsified, VMS_MAXRSS, char);
7335 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7336 PerlMem_free(pathified);
7337 if (vmsified) Safefree(vmsified);
7340 PerlMem_free(pathified);
7345 vmslen = strlen(vmsified);
7346 Newx(cp,vmslen+1,char);
7347 memcpy(cp,vmsified,vmslen);
7353 strcpy(__tovmspath_retbuf,vmsified);
7355 return __tovmspath_retbuf;
7358 } /* end of do_tovmspath() */
7360 /* External entry points */
7361 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7362 { return do_tovmspath(path,buf,0, NULL); }
7363 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7364 { return do_tovmspath(path,buf,1, NULL); }
7365 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7366 { return do_tovmspath(path,buf,0,utf8_fl); }
7367 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7368 { return do_tovmspath(path,buf,1,utf8_fl); }
7371 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7372 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7373 static char __tounixpath_retbuf[VMS_MAXRSS];
7375 char *pathified, *unixified, *cp;
7377 if (path == NULL) return NULL;
7378 pathified = PerlMem_malloc(VMS_MAXRSS);
7379 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7380 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7381 PerlMem_free(pathified);
7387 Newx(unixified, VMS_MAXRSS, char);
7389 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7390 PerlMem_free(pathified);
7391 if (unixified) Safefree(unixified);
7394 PerlMem_free(pathified);
7399 unixlen = strlen(unixified);
7400 Newx(cp,unixlen+1,char);
7401 memcpy(cp,unixified,unixlen);
7403 Safefree(unixified);
7407 strcpy(__tounixpath_retbuf,unixified);
7408 Safefree(unixified);
7409 return __tounixpath_retbuf;
7412 } /* end of do_tounixpath() */
7414 /* External entry points */
7415 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7416 { return do_tounixpath(path,buf,0,NULL); }
7417 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7418 { return do_tounixpath(path,buf,1,NULL); }
7419 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7420 { return do_tounixpath(path,buf,0,utf8_fl); }
7421 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7422 { return do_tounixpath(path,buf,1,utf8_fl); }
7425 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
7427 *****************************************************************************
7429 * Copyright (C) 1989-1994 by *
7430 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
7432 * Permission is hereby granted for the reproduction of this software, *
7433 * on condition that this copyright notice is included in the reproduction, *
7434 * and that such reproduction is not for purposes of profit or material *
7437 * 27-Aug-1994 Modified for inclusion in perl5 *
7438 * by Charles Bailey bailey@newman.upenn.edu *
7439 *****************************************************************************
7443 * getredirection() is intended to aid in porting C programs
7444 * to VMS (Vax-11 C). The native VMS environment does not support
7445 * '>' and '<' I/O redirection, or command line wild card expansion,
7446 * or a command line pipe mechanism using the '|' AND background
7447 * command execution '&'. All of these capabilities are provided to any
7448 * C program which calls this procedure as the first thing in the
7450 * The piping mechanism will probably work with almost any 'filter' type
7451 * of program. With suitable modification, it may useful for other
7452 * portability problems as well.
7454 * Author: Mark Pizzolato mark@infocomm.com
7458 struct list_item *next;
7462 static void add_item(struct list_item **head,
7463 struct list_item **tail,
7467 static void mp_expand_wild_cards(pTHX_ char *item,
7468 struct list_item **head,
7469 struct list_item **tail,
7472 static int background_process(pTHX_ int argc, char **argv);
7474 static void pipe_and_fork(pTHX_ char **cmargv);
7476 /*{{{ void getredirection(int *ac, char ***av)*/
7478 mp_getredirection(pTHX_ int *ac, char ***av)
7480 * Process vms redirection arg's. Exit if any error is seen.
7481 * If getredirection() processes an argument, it is erased
7482 * from the vector. getredirection() returns a new argc and argv value.
7483 * In the event that a background command is requested (by a trailing "&"),
7484 * this routine creates a background subprocess, and simply exits the program.
7486 * Warning: do not try to simplify the code for vms. The code
7487 * presupposes that getredirection() is called before any data is
7488 * read from stdin or written to stdout.
7490 * Normal usage is as follows:
7496 * getredirection(&argc, &argv);
7500 int argc = *ac; /* Argument Count */
7501 char **argv = *av; /* Argument Vector */
7502 char *ap; /* Argument pointer */
7503 int j; /* argv[] index */
7504 int item_count = 0; /* Count of Items in List */
7505 struct list_item *list_head = 0; /* First Item in List */
7506 struct list_item *list_tail; /* Last Item in List */
7507 char *in = NULL; /* Input File Name */
7508 char *out = NULL; /* Output File Name */
7509 char *outmode = "w"; /* Mode to Open Output File */
7510 char *err = NULL; /* Error File Name */
7511 char *errmode = "w"; /* Mode to Open Error File */
7512 int cmargc = 0; /* Piped Command Arg Count */
7513 char **cmargv = NULL;/* Piped Command Arg Vector */
7516 * First handle the case where the last thing on the line ends with
7517 * a '&'. This indicates the desire for the command to be run in a
7518 * subprocess, so we satisfy that desire.
7521 if (0 == strcmp("&", ap))
7522 exit(background_process(aTHX_ --argc, argv));
7523 if (*ap && '&' == ap[strlen(ap)-1])
7525 ap[strlen(ap)-1] = '\0';
7526 exit(background_process(aTHX_ argc, argv));
7529 * Now we handle the general redirection cases that involve '>', '>>',
7530 * '<', and pipes '|'.
7532 for (j = 0; j < argc; ++j)
7534 if (0 == strcmp("<", argv[j]))
7538 fprintf(stderr,"No input file after < on command line");
7539 exit(LIB$_WRONUMARG);
7544 if ('<' == *(ap = argv[j]))
7549 if (0 == strcmp(">", ap))
7553 fprintf(stderr,"No output file after > on command line");
7554 exit(LIB$_WRONUMARG);
7573 fprintf(stderr,"No output file after > or >> on command line");
7574 exit(LIB$_WRONUMARG);
7578 if (('2' == *ap) && ('>' == ap[1]))
7595 fprintf(stderr,"No output file after 2> or 2>> on command line");
7596 exit(LIB$_WRONUMARG);
7600 if (0 == strcmp("|", argv[j]))
7604 fprintf(stderr,"No command into which to pipe on command line");
7605 exit(LIB$_WRONUMARG);
7607 cmargc = argc-(j+1);
7608 cmargv = &argv[j+1];
7612 if ('|' == *(ap = argv[j]))
7620 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7623 * Allocate and fill in the new argument vector, Some Unix's terminate
7624 * the list with an extra null pointer.
7626 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7627 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7629 for (j = 0; j < item_count; ++j, list_head = list_head->next)
7630 argv[j] = list_head->value;
7636 fprintf(stderr,"'|' and '>' may not both be specified on command line");
7637 exit(LIB$_INVARGORD);
7639 pipe_and_fork(aTHX_ cmargv);
7642 /* Check for input from a pipe (mailbox) */
7644 if (in == NULL && 1 == isapipe(0))
7646 char mbxname[L_tmpnam];
7648 long int dvi_item = DVI$_DEVBUFSIZ;
7649 $DESCRIPTOR(mbxnam, "");
7650 $DESCRIPTOR(mbxdevnam, "");
7652 /* Input from a pipe, reopen it in binary mode to disable */
7653 /* carriage control processing. */
7655 fgetname(stdin, mbxname);
7656 mbxnam.dsc$a_pointer = mbxname;
7657 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7658 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7659 mbxdevnam.dsc$a_pointer = mbxname;
7660 mbxdevnam.dsc$w_length = sizeof(mbxname);
7661 dvi_item = DVI$_DEVNAM;
7662 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7663 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7666 freopen(mbxname, "rb", stdin);
7669 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7673 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7675 fprintf(stderr,"Can't open input file %s as stdin",in);
7678 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7680 fprintf(stderr,"Can't open output file %s as stdout",out);
7683 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7686 if (strcmp(err,"&1") == 0) {
7687 dup2(fileno(stdout), fileno(stderr));
7688 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7691 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7693 fprintf(stderr,"Can't open error file %s as stderr",err);
7697 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7701 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7704 #ifdef ARGPROC_DEBUG
7705 PerlIO_printf(Perl_debug_log, "Arglist:\n");
7706 for (j = 0; j < *ac; ++j)
7707 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7709 /* Clear errors we may have hit expanding wildcards, so they don't
7710 show up in Perl's $! later */
7711 set_errno(0); set_vaxc_errno(1);
7712 } /* end of getredirection() */
7715 static void add_item(struct list_item **head,
7716 struct list_item **tail,
7722 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7723 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7727 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7728 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7729 *tail = (*tail)->next;
7731 (*tail)->value = value;
7735 static void mp_expand_wild_cards(pTHX_ char *item,
7736 struct list_item **head,
7737 struct list_item **tail,
7741 unsigned long int context = 0;
7749 $DESCRIPTOR(filespec, "");
7750 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7751 $DESCRIPTOR(resultspec, "");
7752 unsigned long int lff_flags = 0;
7756 #ifdef VMS_LONGNAME_SUPPORT
7757 lff_flags = LIB$M_FIL_LONG_NAMES;
7760 for (cp = item; *cp; cp++) {
7761 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7762 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7764 if (!*cp || isspace(*cp))
7766 add_item(head, tail, item, count);
7771 /* "double quoted" wild card expressions pass as is */
7772 /* From DCL that means using e.g.: */
7773 /* perl program """perl.*""" */
7774 item_len = strlen(item);
7775 if ( '"' == *item && '"' == item[item_len-1] )
7778 item[item_len-2] = '\0';
7779 add_item(head, tail, item, count);
7783 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7784 resultspec.dsc$b_class = DSC$K_CLASS_D;
7785 resultspec.dsc$a_pointer = NULL;
7786 vmsspec = PerlMem_malloc(VMS_MAXRSS);
7787 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7788 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7789 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
7790 if (!isunix || !filespec.dsc$a_pointer)
7791 filespec.dsc$a_pointer = item;
7792 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7794 * Only return version specs, if the caller specified a version
7796 had_version = strchr(item, ';');
7798 * Only return device and directory specs, if the caller specifed either.
7800 had_device = strchr(item, ':');
7801 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7803 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7804 (&filespec, &resultspec, &context,
7805 &defaultspec, 0, &rms_sts, &lff_flags)))
7810 string = PerlMem_malloc(resultspec.dsc$w_length+1);
7811 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7812 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7813 string[resultspec.dsc$w_length] = '\0';
7814 if (NULL == had_version)
7815 *(strrchr(string, ';')) = '\0';
7816 if ((!had_directory) && (had_device == NULL))
7818 if (NULL == (devdir = strrchr(string, ']')))
7819 devdir = strrchr(string, '>');
7820 strcpy(string, devdir + 1);
7823 * Be consistent with what the C RTL has already done to the rest of
7824 * the argv items and lowercase all of these names.
7826 if (!decc_efs_case_preserve) {
7827 for (c = string; *c; ++c)
7831 if (isunix) trim_unixpath(string,item,1);
7832 add_item(head, tail, string, count);
7835 PerlMem_free(vmsspec);
7836 if (sts != RMS$_NMF)
7838 set_vaxc_errno(sts);
7841 case RMS$_FNF: case RMS$_DNF:
7842 set_errno(ENOENT); break;
7844 set_errno(ENOTDIR); break;
7846 set_errno(ENODEV); break;
7847 case RMS$_FNM: case RMS$_SYN:
7848 set_errno(EINVAL); break;
7850 set_errno(EACCES); break;
7852 _ckvmssts_noperl(sts);
7856 add_item(head, tail, item, count);
7857 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7858 _ckvmssts_noperl(lib$find_file_end(&context));
7861 static int child_st[2];/* Event Flag set when child process completes */
7863 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
7865 static unsigned long int exit_handler(int *status)
7869 if (0 == child_st[0])
7871 #ifdef ARGPROC_DEBUG
7872 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7874 fflush(stdout); /* Have to flush pipe for binary data to */
7875 /* terminate properly -- <tp@mccall.com> */
7876 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7877 sys$dassgn(child_chan);
7879 sys$synch(0, child_st);
7884 static void sig_child(int chan)
7886 #ifdef ARGPROC_DEBUG
7887 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7889 if (child_st[0] == 0)
7893 static struct exit_control_block exit_block =
7898 &exit_block.exit_status,
7903 pipe_and_fork(pTHX_ char **cmargv)
7906 struct dsc$descriptor_s *vmscmd;
7907 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7908 int sts, j, l, ismcr, quote, tquote = 0;
7910 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
7911 vms_execfree(vmscmd);
7916 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
7917 && toupper(*(q+2)) == 'R' && !*(q+3);
7919 while (q && l < MAX_DCL_LINE_LENGTH) {
7921 if (j > 0 && quote) {
7927 if (ismcr && j > 1) quote = 1;
7928 tquote = (strchr(q,' ')) != NULL || *q == '\0';
7931 if (quote || tquote) {
7937 if ((quote||tquote) && *q == '"') {
7947 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7949 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7953 static int background_process(pTHX_ int argc, char **argv)
7955 char command[MAX_DCL_SYMBOL + 1] = "$";
7956 $DESCRIPTOR(value, "");
7957 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7958 static $DESCRIPTOR(null, "NLA0:");
7959 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7961 $DESCRIPTOR(pidstr, "");
7963 unsigned long int flags = 17, one = 1, retsts;
7966 strcat(command, argv[0]);
7967 len = strlen(command);
7968 while (--argc && (len < MAX_DCL_SYMBOL))
7970 strcat(command, " \"");
7971 strcat(command, *(++argv));
7972 strcat(command, "\"");
7973 len = strlen(command);
7975 value.dsc$a_pointer = command;
7976 value.dsc$w_length = strlen(value.dsc$a_pointer);
7977 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7978 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7979 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7980 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7983 _ckvmssts_noperl(retsts);
7985 #ifdef ARGPROC_DEBUG
7986 PerlIO_printf(Perl_debug_log, "%s\n", command);
7988 sprintf(pidstring, "%08X", pid);
7989 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7990 pidstr.dsc$a_pointer = pidstring;
7991 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7992 lib$set_symbol(&pidsymbol, &pidstr);
7996 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7999 /* OS-specific initialization at image activation (not thread startup) */
8000 /* Older VAXC header files lack these constants */
8001 #ifndef JPI$_RIGHTS_SIZE
8002 # define JPI$_RIGHTS_SIZE 817
8004 #ifndef KGB$M_SUBSYSTEM
8005 # define KGB$M_SUBSYSTEM 0x8
8008 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8010 /*{{{void vms_image_init(int *, char ***)*/
8012 vms_image_init(int *argcp, char ***argvp)
8014 char eqv[LNM$C_NAMLENGTH+1] = "";
8015 unsigned int len, tabct = 8, tabidx = 0;
8016 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8017 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8018 unsigned short int dummy, rlen;
8019 struct dsc$descriptor_s **tabvec;
8020 #if defined(PERL_IMPLICIT_CONTEXT)
8023 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8024 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8025 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8028 #ifdef KILL_BY_SIGPRC
8029 Perl_csighandler_init();
8032 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8033 _ckvmssts_noperl(iosb[0]);
8034 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8035 if (iprv[i]) { /* Running image installed with privs? */
8036 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
8041 /* Rights identifiers might trigger tainting as well. */
8042 if (!will_taint && (rlen || rsz)) {
8043 while (rlen < rsz) {
8044 /* We didn't get all the identifiers on the first pass. Allocate a
8045 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8046 * were needed to hold all identifiers at time of last call; we'll
8047 * allocate that many unsigned long ints), and go back and get 'em.
8048 * If it gave us less than it wanted to despite ample buffer space,
8049 * something's broken. Is your system missing a system identifier?
8051 if (rsz <= jpilist[1].buflen) {
8052 /* Perl_croak accvios when used this early in startup. */
8053 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8054 rsz, (unsigned long) jpilist[1].buflen,
8055 "Check your rights database for corruption.\n");
8058 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8059 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8060 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8061 jpilist[1].buflen = rsz * sizeof(unsigned long int);
8062 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8063 _ckvmssts_noperl(iosb[0]);
8065 mask = jpilist[1].bufadr;
8066 /* Check attribute flags for each identifier (2nd longword); protected
8067 * subsystem identifiers trigger tainting.
8069 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8070 if (mask[i] & KGB$M_SUBSYSTEM) {
8075 if (mask != rlst) PerlMem_free(mask);
8078 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8079 * logical, some versions of the CRTL will add a phanthom /000000/
8080 * directory. This needs to be removed.
8082 if (decc_filename_unix_report) {
8085 ulen = strlen(argvp[0][0]);
8087 zeros = strstr(argvp[0][0], "/000000/");
8088 if (zeros != NULL) {
8090 mlen = ulen - (zeros - argvp[0][0]) - 7;
8091 memmove(zeros, &zeros[7], mlen);
8093 argvp[0][0][ulen] = '\0';
8096 /* It also may have a trailing dot that needs to be removed otherwise
8097 * it will be converted to VMS mode incorrectly.
8100 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8101 argvp[0][0][ulen] = '\0';
8104 /* We need to use this hack to tell Perl it should run with tainting,
8105 * since its tainting flag may be part of the PL_curinterp struct, which
8106 * hasn't been allocated when vms_image_init() is called.
8109 char **newargv, **oldargv;
8111 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8112 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8113 newargv[0] = oldargv[0];
8114 newargv[1] = PerlMem_malloc(3 * sizeof(char));
8115 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8116 strcpy(newargv[1], "-T");
8117 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8119 newargv[*argcp] = NULL;
8120 /* We orphan the old argv, since we don't know where it's come from,
8121 * so we don't know how to free it.
8125 else { /* Did user explicitly request tainting? */
8127 char *cp, **av = *argvp;
8128 for (i = 1; i < *argcp; i++) {
8129 if (*av[i] != '-') break;
8130 for (cp = av[i]+1; *cp; cp++) {
8131 if (*cp == 'T') { will_taint = 1; break; }
8132 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8133 strchr("DFIiMmx",*cp)) break;
8135 if (will_taint) break;
8140 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8143 tabvec = (struct dsc$descriptor_s **)
8144 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8145 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8147 else if (tabidx >= tabct) {
8149 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8150 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8152 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8153 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8154 tabvec[tabidx]->dsc$w_length = 0;
8155 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
8156 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
8157 tabvec[tabidx]->dsc$a_pointer = NULL;
8158 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8160 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8162 getredirection(argcp,argvp);
8163 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8165 # include <reentrancy.h>
8166 decc$set_reentrancy(C$C_MULTITHREAD);
8175 * Trim Unix-style prefix off filespec, so it looks like what a shell
8176 * glob expansion would return (i.e. from specified prefix on, not
8177 * full path). Note that returned filespec is Unix-style, regardless
8178 * of whether input filespec was VMS-style or Unix-style.
8180 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8181 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
8182 * vector of options; at present, only bit 0 is used, and if set tells
8183 * trim unixpath to try the current default directory as a prefix when
8184 * presented with a possibly ambiguous ... wildcard.
8186 * Returns !=0 on success, with trimmed filespec replacing contents of
8187 * fspec, and 0 on failure, with contents of fpsec unchanged.
8189 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8191 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8193 char *unixified, *unixwild,
8194 *template, *base, *end, *cp1, *cp2;
8195 register int tmplen, reslen = 0, dirs = 0;
8197 unixwild = PerlMem_malloc(VMS_MAXRSS);
8198 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8199 if (!wildspec || !fspec) return 0;
8200 template = unixwild;
8201 if (strpbrk(wildspec,"]>:") != NULL) {
8202 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8203 PerlMem_free(unixwild);
8208 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8209 unixwild[VMS_MAXRSS-1] = 0;
8211 unixified = PerlMem_malloc(VMS_MAXRSS);
8212 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8213 if (strpbrk(fspec,"]>:") != NULL) {
8214 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8215 PerlMem_free(unixwild);
8216 PerlMem_free(unixified);
8219 else base = unixified;
8220 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8221 * check to see that final result fits into (isn't longer than) fspec */
8222 reslen = strlen(fspec);
8226 /* No prefix or absolute path on wildcard, so nothing to remove */
8227 if (!*template || *template == '/') {
8228 PerlMem_free(unixwild);
8229 if (base == fspec) {
8230 PerlMem_free(unixified);
8233 tmplen = strlen(unixified);
8234 if (tmplen > reslen) {
8235 PerlMem_free(unixified);
8236 return 0; /* not enough space */
8238 /* Copy unixified resultant, including trailing NUL */
8239 memmove(fspec,unixified,tmplen+1);
8240 PerlMem_free(unixified);
8244 for (end = base; *end; end++) ; /* Find end of resultant filespec */
8245 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8246 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8247 for (cp1 = end ;cp1 >= base; cp1--)
8248 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8250 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8251 PerlMem_free(unixified);
8252 PerlMem_free(unixwild);
8257 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8258 int ells = 1, totells, segdirs, match;
8259 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8260 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8262 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8264 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8265 tpl = PerlMem_malloc(VMS_MAXRSS);
8266 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8267 if (ellipsis == template && opts & 1) {
8268 /* Template begins with an ellipsis. Since we can't tell how many
8269 * directory names at the front of the resultant to keep for an
8270 * arbitrary starting point, we arbitrarily choose the current
8271 * default directory as a starting point. If it's there as a prefix,
8272 * clip it off. If not, fall through and act as if the leading
8273 * ellipsis weren't there (i.e. return shortest possible path that
8274 * could match template).
8276 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8278 PerlMem_free(unixified);
8279 PerlMem_free(unixwild);
8282 if (!decc_efs_case_preserve) {
8283 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8284 if (_tolower(*cp1) != _tolower(*cp2)) break;
8286 segdirs = dirs - totells; /* Min # of dirs we must have left */
8287 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8288 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8289 memmove(fspec,cp2+1,end - cp2);
8291 PerlMem_free(unixified);
8292 PerlMem_free(unixwild);
8296 /* First off, back up over constant elements at end of path */
8298 for (front = end ; front >= base; front--)
8299 if (*front == '/' && !dirs--) { front++; break; }
8301 lcres = PerlMem_malloc(VMS_MAXRSS);
8302 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8303 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8305 if (!decc_efs_case_preserve) {
8306 *cp2 = _tolower(*cp1); /* Make lc copy for match */
8314 PerlMem_free(unixified);
8315 PerlMem_free(unixwild);
8316 PerlMem_free(lcres);
8317 return 0; /* Path too long. */
8320 *cp2 = '\0'; /* Pick up with memcpy later */
8321 lcfront = lcres + (front - base);
8322 /* Now skip over each ellipsis and try to match the path in front of it. */
8324 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8325 if (*(cp1) == '.' && *(cp1+1) == '.' &&
8326 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
8327 if (cp1 < template) break; /* template started with an ellipsis */
8328 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8329 ellipsis = cp1; continue;
8331 wilddsc.dsc$a_pointer = tpl;
8332 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8334 for (segdirs = 0, cp2 = tpl;
8335 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8337 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8339 if (!decc_efs_case_preserve) {
8340 *cp2 = _tolower(*cp1); /* else lowercase for match */
8343 *cp2 = *cp1; /* else preserve case for match */
8346 if (*cp2 == '/') segdirs++;
8348 if (cp1 != ellipsis - 1) {
8350 PerlMem_free(unixified);
8351 PerlMem_free(unixwild);
8352 PerlMem_free(lcres);
8353 return 0; /* Path too long */
8355 /* Back up at least as many dirs as in template before matching */
8356 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8357 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8358 for (match = 0; cp1 > lcres;) {
8359 resdsc.dsc$a_pointer = cp1;
8360 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8362 if (match == 1) lcfront = cp1;
8364 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8368 PerlMem_free(unixified);
8369 PerlMem_free(unixwild);
8370 PerlMem_free(lcres);
8371 return 0; /* Can't find prefix ??? */
8373 if (match > 1 && opts & 1) {
8374 /* This ... wildcard could cover more than one set of dirs (i.e.
8375 * a set of similar dir names is repeated). If the template
8376 * contains more than 1 ..., upstream elements could resolve the
8377 * ambiguity, but it's not worth a full backtracking setup here.
8378 * As a quick heuristic, clip off the current default directory
8379 * if it's present to find the trimmed spec, else use the
8380 * shortest string that this ... could cover.
8382 char def[NAM$C_MAXRSS+1], *st;
8384 if (getcwd(def, sizeof def,0) == NULL) {
8385 Safefree(unixified);
8391 if (!decc_efs_case_preserve) {
8392 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8393 if (_tolower(*cp1) != _tolower(*cp2)) break;
8395 segdirs = dirs - totells; /* Min # of dirs we must have left */
8396 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8397 if (*cp1 == '\0' && *cp2 == '/') {
8398 memmove(fspec,cp2+1,end - cp2);
8400 PerlMem_free(unixified);
8401 PerlMem_free(unixwild);
8402 PerlMem_free(lcres);
8405 /* Nope -- stick with lcfront from above and keep going. */
8408 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8410 PerlMem_free(unixified);
8411 PerlMem_free(unixwild);
8412 PerlMem_free(lcres);
8417 } /* end of trim_unixpath() */
8422 * VMS readdir() routines.
8423 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8425 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
8426 * Minor modifications to original routines.
8429 /* readdir may have been redefined by reentr.h, so make sure we get
8430 * the local version for what we do here.
8435 #if !defined(PERL_IMPLICIT_CONTEXT)
8436 # define readdir Perl_readdir
8438 # define readdir(a) Perl_readdir(aTHX_ a)
8441 /* Number of elements in vms_versions array */
8442 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
8445 * Open a directory, return a handle for later use.
8447 /*{{{ DIR *opendir(char*name) */
8449 Perl_opendir(pTHX_ const char *name)
8457 if (decc_efs_charset) {
8458 unix_flag = is_unix_filespec(name);
8461 Newx(dir, VMS_MAXRSS, char);
8462 if (do_tovmspath(name,dir,0,NULL) == NULL) {
8466 /* Check access before stat; otherwise stat does not
8467 * accurately report whether it's a directory.
8469 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8470 /* cando_by_name has already set errno */
8474 if (flex_stat(dir,&sb) == -1) return NULL;
8475 if (!S_ISDIR(sb.st_mode)) {
8477 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
8480 /* Get memory for the handle, and the pattern. */
8482 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8484 /* Fill in the fields; mainly playing with the descriptor. */
8485 sprintf(dd->pattern, "%s*.*",dir);
8491 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8492 dd->pat.dsc$a_pointer = dd->pattern;
8493 dd->pat.dsc$w_length = strlen(dd->pattern);
8494 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8495 dd->pat.dsc$b_class = DSC$K_CLASS_S;
8496 #if defined(USE_ITHREADS)
8497 Newx(dd->mutex,1,perl_mutex);
8498 MUTEX_INIT( (perl_mutex *) dd->mutex );
8504 } /* end of opendir() */
8508 * Set the flag to indicate we want versions or not.
8510 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8512 vmsreaddirversions(DIR *dd, int flag)
8515 dd->flags |= PERL_VMSDIR_M_VERSIONS;
8517 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8522 * Free up an opened directory.
8524 /*{{{ void closedir(DIR *dd)*/
8526 Perl_closedir(DIR *dd)
8530 sts = lib$find_file_end(&dd->context);
8531 Safefree(dd->pattern);
8532 #if defined(USE_ITHREADS)
8533 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8534 Safefree(dd->mutex);
8541 * Collect all the version numbers for the current file.
8544 collectversions(pTHX_ DIR *dd)
8546 struct dsc$descriptor_s pat;
8547 struct dsc$descriptor_s res;
8549 char *p, *text, *buff;
8551 unsigned long context, tmpsts;
8553 /* Convenient shorthand. */
8556 /* Add the version wildcard, ignoring the "*.*" put on before */
8557 i = strlen(dd->pattern);
8558 Newx(text,i + e->d_namlen + 3,char);
8559 strcpy(text, dd->pattern);
8560 sprintf(&text[i - 3], "%s;*", e->d_name);
8562 /* Set up the pattern descriptor. */
8563 pat.dsc$a_pointer = text;
8564 pat.dsc$w_length = i + e->d_namlen - 1;
8565 pat.dsc$b_dtype = DSC$K_DTYPE_T;
8566 pat.dsc$b_class = DSC$K_CLASS_S;
8568 /* Set up result descriptor. */
8569 Newx(buff, VMS_MAXRSS, char);
8570 res.dsc$a_pointer = buff;
8571 res.dsc$w_length = VMS_MAXRSS - 1;
8572 res.dsc$b_dtype = DSC$K_DTYPE_T;
8573 res.dsc$b_class = DSC$K_CLASS_S;
8575 /* Read files, collecting versions. */
8576 for (context = 0, e->vms_verscount = 0;
8577 e->vms_verscount < VERSIZE(e);
8578 e->vms_verscount++) {
8580 unsigned long flags = 0;
8582 #ifdef VMS_LONGNAME_SUPPORT
8583 flags = LIB$M_FIL_LONG_NAMES;
8585 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8586 if (tmpsts == RMS$_NMF || context == 0) break;
8588 buff[VMS_MAXRSS - 1] = '\0';
8589 if ((p = strchr(buff, ';')))
8590 e->vms_versions[e->vms_verscount] = atoi(p + 1);
8592 e->vms_versions[e->vms_verscount] = -1;
8595 _ckvmssts(lib$find_file_end(&context));
8599 } /* end of collectversions() */
8602 * Read the next entry from the directory.
8604 /*{{{ struct dirent *readdir(DIR *dd)*/
8606 Perl_readdir(pTHX_ DIR *dd)
8608 struct dsc$descriptor_s res;
8610 unsigned long int tmpsts;
8612 unsigned long flags = 0;
8613 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8614 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8616 /* Set up result descriptor, and get next file. */
8617 Newx(buff, VMS_MAXRSS, char);
8618 res.dsc$a_pointer = buff;
8619 res.dsc$w_length = VMS_MAXRSS - 1;
8620 res.dsc$b_dtype = DSC$K_DTYPE_T;
8621 res.dsc$b_class = DSC$K_CLASS_S;
8623 #ifdef VMS_LONGNAME_SUPPORT
8624 flags = LIB$M_FIL_LONG_NAMES;
8627 tmpsts = lib$find_file
8628 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8629 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
8630 if (!(tmpsts & 1)) {
8631 set_vaxc_errno(tmpsts);
8634 set_errno(EACCES); break;
8636 set_errno(ENODEV); break;
8638 set_errno(ENOTDIR); break;
8639 case RMS$_FNF: case RMS$_DNF:
8640 set_errno(ENOENT); break;
8648 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8649 if (!decc_efs_case_preserve) {
8650 buff[VMS_MAXRSS - 1] = '\0';
8651 for (p = buff; *p; p++) *p = _tolower(*p);
8654 /* we don't want to force to lowercase, just null terminate */
8655 buff[res.dsc$w_length] = '\0';
8657 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
8660 /* Skip any directory component and just copy the name. */
8661 sts = vms_split_path
8676 /* Drop NULL extensions on UNIX file specification */
8677 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8678 (e_len == 1) && decc_readdir_dropdotnotype)) {
8683 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8684 dd->entry.d_name[n_len + e_len] = '\0';
8685 dd->entry.d_namlen = strlen(dd->entry.d_name);
8687 /* Convert the filename to UNIX format if needed */
8688 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8690 /* Translate the encoded characters. */
8691 /* Fixme: unicode handling could result in embedded 0 characters */
8692 if (strchr(dd->entry.d_name, '^') != NULL) {
8696 p = dd->entry.d_name;
8700 x = copy_expand_vms_filename_escape(q, p, &y);
8704 /* if y > 1, then this is a wide file specification */
8705 /* Wide file specifications need to be passed in Perl */
8706 /* counted strings apparently with a unicode flag */
8709 strcpy(dd->entry.d_name, new_name);
8713 dd->entry.vms_verscount = 0;
8714 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8718 } /* end of readdir() */
8722 * Read the next entry from the directory -- thread-safe version.
8724 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8726 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8730 MUTEX_LOCK( (perl_mutex *) dd->mutex );
8732 entry = readdir(dd);
8734 retval = ( *result == NULL ? errno : 0 );
8736 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8740 } /* end of readdir_r() */
8744 * Return something that can be used in a seekdir later.
8746 /*{{{ long telldir(DIR *dd)*/
8748 Perl_telldir(DIR *dd)
8755 * Return to a spot where we used to be. Brute force.
8757 /*{{{ void seekdir(DIR *dd,long count)*/
8759 Perl_seekdir(pTHX_ DIR *dd, long count)
8763 /* If we haven't done anything yet... */
8767 /* Remember some state, and clear it. */
8768 old_flags = dd->flags;
8769 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8770 _ckvmssts(lib$find_file_end(&dd->context));
8773 /* The increment is in readdir(). */
8774 for (dd->count = 0; dd->count < count; )
8777 dd->flags = old_flags;
8779 } /* end of seekdir() */
8782 /* VMS subprocess management
8784 * my_vfork() - just a vfork(), after setting a flag to record that
8785 * the current script is trying a Unix-style fork/exec.
8787 * vms_do_aexec() and vms_do_exec() are called in response to the
8788 * perl 'exec' function. If this follows a vfork call, then they
8789 * call out the regular perl routines in doio.c which do an
8790 * execvp (for those who really want to try this under VMS).
8791 * Otherwise, they do exactly what the perl docs say exec should
8792 * do - terminate the current script and invoke a new command
8793 * (See below for notes on command syntax.)
8795 * do_aspawn() and do_spawn() implement the VMS side of the perl
8796 * 'system' function.
8798 * Note on command arguments to perl 'exec' and 'system': When handled
8799 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8800 * are concatenated to form a DCL command string. If the first arg
8801 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8802 * the command string is handed off to DCL directly. Otherwise,
8803 * the first token of the command is taken as the filespec of an image
8804 * to run. The filespec is expanded using a default type of '.EXE' and
8805 * the process defaults for device, directory, etc., and if found, the resultant
8806 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8807 * the command string as parameters. This is perhaps a bit complicated,
8808 * but I hope it will form a happy medium between what VMS folks expect
8809 * from lib$spawn and what Unix folks expect from exec.
8812 static int vfork_called;
8814 /*{{{int my_vfork()*/
8825 vms_execfree(struct dsc$descriptor_s *vmscmd)
8828 if (vmscmd->dsc$a_pointer) {
8829 PerlMem_free(vmscmd->dsc$a_pointer);
8831 PerlMem_free(vmscmd);
8836 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8838 char *junk, *tmps = Nullch;
8839 register size_t cmdlen = 0;
8846 tmps = SvPV(really,rlen);
8853 for (idx++; idx <= sp; idx++) {
8855 junk = SvPVx(*idx,rlen);
8856 cmdlen += rlen ? rlen + 1 : 0;
8859 Newx(PL_Cmd, cmdlen+1, char);
8861 if (tmps && *tmps) {
8862 strcpy(PL_Cmd,tmps);
8865 else *PL_Cmd = '\0';
8866 while (++mark <= sp) {
8868 char *s = SvPVx(*mark,n_a);
8870 if (*PL_Cmd) strcat(PL_Cmd," ");
8876 } /* end of setup_argstr() */
8879 static unsigned long int
8880 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8881 struct dsc$descriptor_s **pvmscmd)
8883 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8884 char image_name[NAM$C_MAXRSS+1];
8885 char image_argv[NAM$C_MAXRSS+1];
8886 $DESCRIPTOR(defdsc,".EXE");
8887 $DESCRIPTOR(defdsc2,".");
8888 $DESCRIPTOR(resdsc,resspec);
8889 struct dsc$descriptor_s *vmscmd;
8890 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8891 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8892 register char *s, *rest, *cp, *wordbreak;
8897 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8898 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8900 /* Make a copy for modification */
8901 cmdlen = strlen(incmd);
8902 cmd = PerlMem_malloc(cmdlen+1);
8903 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8904 strncpy(cmd, incmd, cmdlen);
8909 vmscmd->dsc$a_pointer = NULL;
8910 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
8911 vmscmd->dsc$b_class = DSC$K_CLASS_S;
8912 vmscmd->dsc$w_length = 0;
8913 if (pvmscmd) *pvmscmd = vmscmd;
8915 if (suggest_quote) *suggest_quote = 0;
8917 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8919 return CLI$_BUFOVF; /* continuation lines currently unsupported */
8924 while (*s && isspace(*s)) s++;
8926 if (*s == '@' || *s == '$') {
8927 vmsspec[0] = *s; rest = s + 1;
8928 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8930 else { cp = vmsspec; rest = s; }
8931 if (*rest == '.' || *rest == '/') {
8934 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8935 rest++, cp2++) *cp2 = *rest;
8937 if (do_tovmsspec(resspec,cp,0,NULL)) {
8940 for (cp2 = vmsspec + strlen(vmsspec);
8941 *rest && cp2 - vmsspec < sizeof vmsspec;
8942 rest++, cp2++) *cp2 = *rest;
8947 /* Intuit whether verb (first word of cmd) is a DCL command:
8948 * - if first nonspace char is '@', it's a DCL indirection
8950 * - if verb contains a filespec separator, it's not a DCL command
8951 * - if it doesn't, caller tells us whether to default to a DCL
8952 * command, or to a local image unless told it's DCL (by leading '$')
8956 if (suggest_quote) *suggest_quote = 1;
8958 register char *filespec = strpbrk(s,":<[.;");
8959 rest = wordbreak = strpbrk(s," \"\t/");
8960 if (!wordbreak) wordbreak = s + strlen(s);
8961 if (*s == '$') check_img = 0;
8962 if (filespec && (filespec < wordbreak)) isdcl = 0;
8963 else isdcl = !check_img;
8968 imgdsc.dsc$a_pointer = s;
8969 imgdsc.dsc$w_length = wordbreak - s;
8970 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8972 _ckvmssts(lib$find_file_end(&cxt));
8973 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8974 if (!(retsts & 1) && *s == '$') {
8975 _ckvmssts(lib$find_file_end(&cxt));
8976 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8977 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8979 _ckvmssts(lib$find_file_end(&cxt));
8980 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8984 _ckvmssts(lib$find_file_end(&cxt));
8989 while (*s && !isspace(*s)) s++;
8992 /* check that it's really not DCL with no file extension */
8993 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8995 char b[256] = {0,0,0,0};
8996 read(fileno(fp), b, 256);
8997 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9001 /* Check for script */
9003 if ((b[0] == '#') && (b[1] == '!'))
9005 #ifdef ALTERNATE_SHEBANG
9007 shebang_len = strlen(ALTERNATE_SHEBANG);
9008 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9010 perlstr = strstr("perl",b);
9011 if (perlstr == NULL)
9019 if (shebang_len > 0) {
9022 char tmpspec[NAM$C_MAXRSS + 1];
9025 /* Image is following after white space */
9026 /*--------------------------------------*/
9027 while (isprint(b[i]) && isspace(b[i]))
9031 while (isprint(b[i]) && !isspace(b[i])) {
9032 tmpspec[j++] = b[i++];
9033 if (j >= NAM$C_MAXRSS)
9038 /* There may be some default parameters to the image */
9039 /*---------------------------------------------------*/
9041 while (isprint(b[i])) {
9042 image_argv[j++] = b[i++];
9043 if (j >= NAM$C_MAXRSS)
9046 while ((j > 0) && !isprint(image_argv[j-1]))
9050 /* It will need to be converted to VMS format and validated */
9051 if (tmpspec[0] != '\0') {
9054 /* Try to find the exact program requested to be run */
9055 /*---------------------------------------------------*/
9056 iname = do_rmsexpand
9057 (tmpspec, image_name, 0, ".exe",
9058 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9059 if (iname != NULL) {
9060 if (cando_by_name_int
9061 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9062 /* MCR prefix needed */
9066 /* Try again with a null type */
9067 /*----------------------------*/
9068 iname = do_rmsexpand
9069 (tmpspec, image_name, 0, ".",
9070 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9071 if (iname != NULL) {
9072 if (cando_by_name_int
9073 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9074 /* MCR prefix needed */
9080 /* Did we find the image to run the script? */
9081 /*------------------------------------------*/
9085 /* Assume DCL or foreign command exists */
9086 /*--------------------------------------*/
9087 tchr = strrchr(tmpspec, '/');
9094 strcpy(image_name, tchr);
9102 if (check_img && isdcl) return RMS$_FNF;
9104 if (cando_by_name(S_IXUSR,0,resspec)) {
9105 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9106 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9108 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9109 if (image_name[0] != 0) {
9110 strcat(vmscmd->dsc$a_pointer, image_name);
9111 strcat(vmscmd->dsc$a_pointer, " ");
9113 } else if (image_name[0] != 0) {
9114 strcpy(vmscmd->dsc$a_pointer, image_name);
9115 strcat(vmscmd->dsc$a_pointer, " ");
9117 strcpy(vmscmd->dsc$a_pointer,"@");
9119 if (suggest_quote) *suggest_quote = 1;
9121 /* If there is an image name, use original command */
9122 if (image_name[0] == 0)
9123 strcat(vmscmd->dsc$a_pointer,resspec);
9126 while (*rest && isspace(*rest)) rest++;
9129 if (image_argv[0] != 0) {
9130 strcat(vmscmd->dsc$a_pointer,image_argv);
9131 strcat(vmscmd->dsc$a_pointer, " ");
9137 rest_len = strlen(rest);
9138 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9139 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9140 strcat(vmscmd->dsc$a_pointer,rest);
9142 retsts = CLI$_BUFOVF;
9144 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9146 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9152 /* It's either a DCL command or we couldn't find a suitable image */
9153 vmscmd->dsc$w_length = strlen(cmd);
9155 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9156 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9157 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9161 /* check if it's a symbol (for quoting purposes) */
9162 if (suggest_quote && !*suggest_quote) {
9164 char equiv[LNM$C_NAMLENGTH];
9165 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9166 eqvdsc.dsc$a_pointer = equiv;
9168 iss = lib$get_symbol(vmscmd,&eqvdsc);
9169 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9171 if (!(retsts & 1)) {
9172 /* just hand off status values likely to be due to user error */
9173 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9174 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9175 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9176 else { _ckvmssts(retsts); }
9179 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9181 } /* end of setup_cmddsc() */
9184 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9186 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9192 if (vfork_called) { /* this follows a vfork - act Unixish */
9194 if (vfork_called < 0) {
9195 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9198 else return do_aexec(really,mark,sp);
9200 /* no vfork - act VMSish */
9201 cmd = setup_argstr(aTHX_ really,mark,sp);
9202 exec_sts = vms_do_exec(cmd);
9203 Safefree(cmd); /* Clean up from setup_argstr() */
9208 } /* end of vms_do_aexec() */
9211 /* {{{bool vms_do_exec(char *cmd) */
9213 Perl_vms_do_exec(pTHX_ const char *cmd)
9215 struct dsc$descriptor_s *vmscmd;
9217 if (vfork_called) { /* this follows a vfork - act Unixish */
9219 if (vfork_called < 0) {
9220 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9223 else return do_exec(cmd);
9226 { /* no vfork - act VMSish */
9227 unsigned long int retsts;
9230 TAINT_PROPER("exec");
9231 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9232 retsts = lib$do_command(vmscmd);
9235 case RMS$_FNF: case RMS$_DNF:
9236 set_errno(ENOENT); break;
9238 set_errno(ENOTDIR); break;
9240 set_errno(ENODEV); break;
9242 set_errno(EACCES); break;
9244 set_errno(EINVAL); break;
9245 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9246 set_errno(E2BIG); break;
9247 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9248 _ckvmssts(retsts); /* fall through */
9249 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9252 set_vaxc_errno(retsts);
9253 if (ckWARN(WARN_EXEC)) {
9254 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9255 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9257 vms_execfree(vmscmd);
9262 } /* end of vms_do_exec() */
9265 unsigned long int Perl_do_spawn(pTHX_ const char *);
9267 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9269 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9271 unsigned long int sts;
9275 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9276 sts = do_spawn(cmd);
9277 /* pp_sys will clean up cmd */
9281 } /* end of do_aspawn() */
9284 /* {{{unsigned long int do_spawn(char *cmd) */
9286 Perl_do_spawn(pTHX_ const char *cmd)
9288 unsigned long int sts, substs;
9290 /* The caller of this routine expects to Safefree(PL_Cmd) */
9291 Newx(PL_Cmd,10,char);
9294 TAINT_PROPER("spawn");
9295 if (!cmd || !*cmd) {
9296 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9299 case RMS$_FNF: case RMS$_DNF:
9300 set_errno(ENOENT); break;
9302 set_errno(ENOTDIR); break;
9304 set_errno(ENODEV); break;
9306 set_errno(EACCES); break;
9308 set_errno(EINVAL); break;
9309 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9310 set_errno(E2BIG); break;
9311 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9312 _ckvmssts(sts); /* fall through */
9313 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9316 set_vaxc_errno(sts);
9317 if (ckWARN(WARN_EXEC)) {
9318 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9326 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9331 } /* end of do_spawn() */
9335 static unsigned int *sockflags, sockflagsize;
9338 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9339 * routines found in some versions of the CRTL can't deal with sockets.
9340 * We don't shim the other file open routines since a socket isn't
9341 * likely to be opened by a name.
9343 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9344 FILE *my_fdopen(int fd, const char *mode)
9346 FILE *fp = fdopen(fd, mode);
9349 unsigned int fdoff = fd / sizeof(unsigned int);
9350 Stat_t sbuf; /* native stat; we don't need flex_stat */
9351 if (!sockflagsize || fdoff > sockflagsize) {
9352 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
9353 else Newx (sockflags,fdoff+2,unsigned int);
9354 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9355 sockflagsize = fdoff + 2;
9357 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9358 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9367 * Clear the corresponding bit when the (possibly) socket stream is closed.
9368 * There still a small hole: we miss an implicit close which might occur
9369 * via freopen(). >> Todo
9371 /*{{{ int my_fclose(FILE *fp)*/
9372 int my_fclose(FILE *fp) {
9374 unsigned int fd = fileno(fp);
9375 unsigned int fdoff = fd / sizeof(unsigned int);
9377 if (sockflagsize && fdoff <= sockflagsize)
9378 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9386 * A simple fwrite replacement which outputs itmsz*nitm chars without
9387 * introducing record boundaries every itmsz chars.
9388 * We are using fputs, which depends on a terminating null. We may
9389 * well be writing binary data, so we need to accommodate not only
9390 * data with nulls sprinkled in the middle but also data with no null
9393 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9395 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9397 register char *cp, *end, *cpd, *data;
9398 register unsigned int fd = fileno(dest);
9399 register unsigned int fdoff = fd / sizeof(unsigned int);
9401 int bufsize = itmsz * nitm + 1;
9403 if (fdoff < sockflagsize &&
9404 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9405 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9409 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9410 memcpy( data, src, itmsz*nitm );
9411 data[itmsz*nitm] = '\0';
9413 end = data + itmsz * nitm;
9414 retval = (int) nitm; /* on success return # items written */
9417 while (cpd <= end) {
9418 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9419 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9421 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9425 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9428 } /* end of my_fwrite() */
9431 /*{{{ int my_flush(FILE *fp)*/
9433 Perl_my_flush(pTHX_ FILE *fp)
9436 if ((res = fflush(fp)) == 0 && fp) {
9437 #ifdef VMS_DO_SOCKETS
9439 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9441 res = fsync(fileno(fp));
9444 * If the flush succeeded but set end-of-file, we need to clear
9445 * the error because our caller may check ferror(). BTW, this
9446 * probably means we just flushed an empty file.
9448 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9455 * Here are replacements for the following Unix routines in the VMS environment:
9456 * getpwuid Get information for a particular UIC or UID
9457 * getpwnam Get information for a named user
9458 * getpwent Get information for each user in the rights database
9459 * setpwent Reset search to the start of the rights database
9460 * endpwent Finish searching for users in the rights database
9462 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9463 * (defined in pwd.h), which contains the following fields:-
9465 * char *pw_name; Username (in lower case)
9466 * char *pw_passwd; Hashed password
9467 * unsigned int pw_uid; UIC
9468 * unsigned int pw_gid; UIC group number
9469 * char *pw_unixdir; Default device/directory (VMS-style)
9470 * char *pw_gecos; Owner name
9471 * char *pw_dir; Default device/directory (Unix-style)
9472 * char *pw_shell; Default CLI name (eg. DCL)
9474 * If the specified user does not exist, getpwuid and getpwnam return NULL.
9476 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9477 * not the UIC member number (eg. what's returned by getuid()),
9478 * getpwuid() can accept either as input (if uid is specified, the caller's
9479 * UIC group is used), though it won't recognise gid=0.
9481 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9482 * information about other users in your group or in other groups, respectively.
9483 * If the required privilege is not available, then these routines fill only
9484 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9487 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9490 /* sizes of various UAF record fields */
9491 #define UAI$S_USERNAME 12
9492 #define UAI$S_IDENT 31
9493 #define UAI$S_OWNER 31
9494 #define UAI$S_DEFDEV 31
9495 #define UAI$S_DEFDIR 63
9496 #define UAI$S_DEFCLI 31
9499 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
9500 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9501 (uic).uic$v_group != UIC$K_WILD_GROUP)
9503 static char __empty[]= "";
9504 static struct passwd __passwd_empty=
9505 {(char *) __empty, (char *) __empty, 0, 0,
9506 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9507 static int contxt= 0;
9508 static struct passwd __pwdcache;
9509 static char __pw_namecache[UAI$S_IDENT+1];
9512 * This routine does most of the work extracting the user information.
9514 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9517 unsigned char length;
9518 char pw_gecos[UAI$S_OWNER+1];
9520 static union uicdef uic;
9522 unsigned char length;
9523 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9526 unsigned char length;
9527 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9530 unsigned char length;
9531 char pw_shell[UAI$S_DEFCLI+1];
9533 static char pw_passwd[UAI$S_PWD+1];
9535 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9536 struct dsc$descriptor_s name_desc;
9537 unsigned long int sts;
9539 static struct itmlst_3 itmlst[]= {
9540 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
9541 {sizeof(uic), UAI$_UIC, &uic, &luic},
9542 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
9543 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
9544 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
9545 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
9546 {0, 0, NULL, NULL}};
9548 name_desc.dsc$w_length= strlen(name);
9549 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9550 name_desc.dsc$b_class= DSC$K_CLASS_S;
9551 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9553 /* Note that sys$getuai returns many fields as counted strings. */
9554 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9555 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9556 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9558 else { _ckvmssts(sts); }
9559 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
9561 if ((int) owner.length < lowner) lowner= (int) owner.length;
9562 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9563 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9564 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9565 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9566 owner.pw_gecos[lowner]= '\0';
9567 defdev.pw_dir[ldefdev+ldefdir]= '\0';
9568 defcli.pw_shell[ldefcli]= '\0';
9569 if (valid_uic(uic)) {
9570 pwd->pw_uid= uic.uic$l_uic;
9571 pwd->pw_gid= uic.uic$v_group;
9574 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9575 pwd->pw_passwd= pw_passwd;
9576 pwd->pw_gecos= owner.pw_gecos;
9577 pwd->pw_dir= defdev.pw_dir;
9578 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9579 pwd->pw_shell= defcli.pw_shell;
9580 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9582 ldir= strlen(pwd->pw_unixdir) - 1;
9583 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9586 strcpy(pwd->pw_unixdir, pwd->pw_dir);
9587 if (!decc_efs_case_preserve)
9588 __mystrtolower(pwd->pw_unixdir);
9593 * Get information for a named user.
9595 /*{{{struct passwd *getpwnam(char *name)*/
9596 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9598 struct dsc$descriptor_s name_desc;
9600 unsigned long int status, sts;
9602 __pwdcache = __passwd_empty;
9603 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9604 /* We still may be able to determine pw_uid and pw_gid */
9605 name_desc.dsc$w_length= strlen(name);
9606 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9607 name_desc.dsc$b_class= DSC$K_CLASS_S;
9608 name_desc.dsc$a_pointer= (char *) name;
9609 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9610 __pwdcache.pw_uid= uic.uic$l_uic;
9611 __pwdcache.pw_gid= uic.uic$v_group;
9614 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9615 set_vaxc_errno(sts);
9616 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9619 else { _ckvmssts(sts); }
9622 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9623 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9624 __pwdcache.pw_name= __pw_namecache;
9626 } /* end of my_getpwnam() */
9630 * Get information for a particular UIC or UID.
9631 * Called by my_getpwent with uid=-1 to list all users.
9633 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9634 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9636 const $DESCRIPTOR(name_desc,__pw_namecache);
9637 unsigned short lname;
9639 unsigned long int status;
9641 if (uid == (unsigned int) -1) {
9643 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9644 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9645 set_vaxc_errno(status);
9646 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9650 else { _ckvmssts(status); }
9651 } while (!valid_uic (uic));
9655 if (!uic.uic$v_group)
9656 uic.uic$v_group= PerlProc_getgid();
9658 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9659 else status = SS$_IVIDENT;
9660 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9661 status == RMS$_PRV) {
9662 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9665 else { _ckvmssts(status); }
9667 __pw_namecache[lname]= '\0';
9668 __mystrtolower(__pw_namecache);
9670 __pwdcache = __passwd_empty;
9671 __pwdcache.pw_name = __pw_namecache;
9673 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9674 The identifier's value is usually the UIC, but it doesn't have to be,
9675 so if we can, we let fillpasswd update this. */
9676 __pwdcache.pw_uid = uic.uic$l_uic;
9677 __pwdcache.pw_gid = uic.uic$v_group;
9679 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9682 } /* end of my_getpwuid() */
9686 * Get information for next user.
9688 /*{{{struct passwd *my_getpwent()*/
9689 struct passwd *Perl_my_getpwent(pTHX)
9691 return (my_getpwuid((unsigned int) -1));
9696 * Finish searching rights database for users.
9698 /*{{{void my_endpwent()*/
9699 void Perl_my_endpwent(pTHX)
9702 _ckvmssts(sys$finish_rdb(&contxt));
9708 #ifdef HOMEGROWN_POSIX_SIGNALS
9709 /* Signal handling routines, pulled into the core from POSIX.xs.
9711 * We need these for threads, so they've been rolled into the core,
9712 * rather than left in POSIX.xs.
9714 * (DRS, Oct 23, 1997)
9717 /* sigset_t is atomic under VMS, so these routines are easy */
9718 /*{{{int my_sigemptyset(sigset_t *) */
9719 int my_sigemptyset(sigset_t *set) {
9720 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9726 /*{{{int my_sigfillset(sigset_t *)*/
9727 int my_sigfillset(sigset_t *set) {
9729 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9730 for (i = 0; i < NSIG; i++) *set |= (1 << i);
9736 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9737 int my_sigaddset(sigset_t *set, int sig) {
9738 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9739 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9740 *set |= (1 << (sig - 1));
9746 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9747 int my_sigdelset(sigset_t *set, int sig) {
9748 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9749 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9750 *set &= ~(1 << (sig - 1));
9756 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9757 int my_sigismember(sigset_t *set, int sig) {
9758 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9759 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9760 return *set & (1 << (sig - 1));
9765 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9766 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9769 /* If set and oset are both null, then things are badly wrong. Bail out. */
9770 if ((oset == NULL) && (set == NULL)) {
9771 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9775 /* If set's null, then we're just handling a fetch. */
9777 tempmask = sigblock(0);
9782 tempmask = sigsetmask(*set);
9785 tempmask = sigblock(*set);
9788 tempmask = sigblock(0);
9789 sigsetmask(*oset & ~tempmask);
9792 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9797 /* Did they pass us an oset? If so, stick our holding mask into it */
9804 #endif /* HOMEGROWN_POSIX_SIGNALS */
9807 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9808 * my_utime(), and flex_stat(), all of which operate on UTC unless
9809 * VMSISH_TIMES is true.
9811 /* method used to handle UTC conversions:
9812 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
9814 static int gmtime_emulation_type;
9815 /* number of secs to add to UTC POSIX-style time to get local time */
9816 static long int utc_offset_secs;
9818 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9819 * in vmsish.h. #undef them here so we can call the CRTL routines
9828 * DEC C previous to 6.0 corrupts the behavior of the /prefix
9829 * qualifier with the extern prefix pragma. This provisional
9830 * hack circumvents this prefix pragma problem in previous
9833 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9834 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9835 # pragma __extern_prefix save
9836 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
9837 # define gmtime decc$__utctz_gmtime
9838 # define localtime decc$__utctz_localtime
9839 # define time decc$__utc_time
9840 # pragma __extern_prefix restore
9842 struct tm *gmtime(), *localtime();
9848 static time_t toutc_dst(time_t loc) {
9851 if ((rsltmp = localtime(&loc)) == NULL) return -1;
9852 loc -= utc_offset_secs;
9853 if (rsltmp->tm_isdst) loc -= 3600;
9856 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9857 ((gmtime_emulation_type || my_time(NULL)), \
9858 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9859 ((secs) - utc_offset_secs))))
9861 static time_t toloc_dst(time_t utc) {
9864 utc += utc_offset_secs;
9865 if ((rsltmp = localtime(&utc)) == NULL) return -1;
9866 if (rsltmp->tm_isdst) utc += 3600;
9869 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9870 ((gmtime_emulation_type || my_time(NULL)), \
9871 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9872 ((secs) + utc_offset_secs))))
9874 #ifndef RTL_USES_UTC
9877 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
9878 DST starts on 1st sun of april at 02:00 std time
9879 ends on last sun of october at 02:00 dst time
9880 see the UCX management command reference, SET CONFIG TIMEZONE
9881 for formatting info.
9883 No, it's not as general as it should be, but then again, NOTHING
9884 will handle UK times in a sensible way.
9889 parse the DST start/end info:
9890 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9894 tz_parse_startend(char *s, struct tm *w, int *past)
9896 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9897 int ly, dozjd, d, m, n, hour, min, sec, j, k;
9902 if (!past) return 0;
9905 if (w->tm_year % 4 == 0) ly = 1;
9906 if (w->tm_year % 100 == 0) ly = 0;
9907 if (w->tm_year+1900 % 400 == 0) ly = 1;
9910 dozjd = isdigit(*s);
9911 if (*s == 'J' || *s == 'j' || dozjd) {
9912 if (!dozjd && !isdigit(*++s)) return 0;
9915 d = d*10 + *s++ - '0';
9917 d = d*10 + *s++ - '0';
9920 if (d == 0) return 0;
9921 if (d > 366) return 0;
9923 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
9926 } else if (*s == 'M' || *s == 'm') {
9927 if (!isdigit(*++s)) return 0;
9929 if (isdigit(*s)) m = 10*m + *s++ - '0';
9930 if (*s != '.') return 0;
9931 if (!isdigit(*++s)) return 0;
9933 if (n < 1 || n > 5) return 0;
9934 if (*s != '.') return 0;
9935 if (!isdigit(*++s)) return 0;
9937 if (d > 6) return 0;
9941 if (!isdigit(*++s)) return 0;
9943 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9945 if (!isdigit(*++s)) return 0;
9947 if (isdigit(*s)) min = 10*min + *s++ - '0';
9949 if (!isdigit(*++s)) return 0;
9951 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9961 if (w->tm_yday < d) goto before;
9962 if (w->tm_yday > d) goto after;
9964 if (w->tm_mon+1 < m) goto before;
9965 if (w->tm_mon+1 > m) goto after;
9967 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
9968 k = d - j; /* mday of first d */
9970 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
9971 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9972 if (w->tm_mday < k) goto before;
9973 if (w->tm_mday > k) goto after;
9976 if (w->tm_hour < hour) goto before;
9977 if (w->tm_hour > hour) goto after;
9978 if (w->tm_min < min) goto before;
9979 if (w->tm_min > min) goto after;
9980 if (w->tm_sec < sec) goto before;
9994 /* parse the offset: (+|-)hh[:mm[:ss]] */
9997 tz_parse_offset(char *s, int *offset)
9999 int hour = 0, min = 0, sec = 0;
10002 if (!offset) return 0;
10004 if (*s == '-') {neg++; s++;}
10005 if (*s == '+') s++;
10006 if (!isdigit(*s)) return 0;
10008 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10009 if (hour > 24) return 0;
10011 if (!isdigit(*++s)) return 0;
10013 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10014 if (min > 59) return 0;
10016 if (!isdigit(*++s)) return 0;
10018 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10019 if (sec > 59) return 0;
10023 *offset = (hour*60+min)*60 + sec;
10024 if (neg) *offset = -*offset;
10029 input time is w, whatever type of time the CRTL localtime() uses.
10030 sets dst, the zone, and the gmtoff (seconds)
10032 caches the value of TZ and UCX$TZ env variables; note that
10033 my_setenv looks for these and sets a flag if they're changed
10036 We have to watch out for the "australian" case (dst starts in
10037 october, ends in april)...flagged by "reverse" and checked by
10038 scanning through the months of the previous year.
10043 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10048 char *dstzone, *tz, *s_start, *s_end;
10049 int std_off, dst_off, isdst;
10050 int y, dststart, dstend;
10051 static char envtz[1025]; /* longer than any logical, symbol, ... */
10052 static char ucxtz[1025];
10053 static char reversed = 0;
10059 reversed = -1; /* flag need to check */
10060 envtz[0] = ucxtz[0] = '\0';
10061 tz = my_getenv("TZ",0);
10062 if (tz) strcpy(envtz, tz);
10063 tz = my_getenv("UCX$TZ",0);
10064 if (tz) strcpy(ucxtz, tz);
10065 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
10068 if (!*tz) tz = ucxtz;
10071 while (isalpha(*s)) s++;
10072 s = tz_parse_offset(s, &std_off);
10074 if (!*s) { /* no DST, hurray we're done! */
10080 while (isalpha(*s)) s++;
10081 s2 = tz_parse_offset(s, &dst_off);
10085 dst_off = std_off - 3600;
10088 if (!*s) { /* default dst start/end?? */
10089 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
10090 s = strchr(ucxtz,',');
10092 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
10094 if (*s != ',') return 0;
10097 when = _toutc(when); /* convert to utc */
10098 when = when - std_off; /* convert to pseudolocal time*/
10100 w2 = localtime(&when);
10103 s = tz_parse_startend(s_start,w2,&dststart);
10105 if (*s != ',') return 0;
10108 when = _toutc(when); /* convert to utc */
10109 when = when - dst_off; /* convert to pseudolocal time*/
10110 w2 = localtime(&when);
10111 if (w2->tm_year != y) { /* spans a year, just check one time */
10112 when += dst_off - std_off;
10113 w2 = localtime(&when);
10116 s = tz_parse_startend(s_end,w2,&dstend);
10119 if (reversed == -1) { /* need to check if start later than end */
10123 if (when < 2*365*86400) {
10124 when += 2*365*86400;
10128 w2 =localtime(&when);
10129 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
10131 for (j = 0; j < 12; j++) {
10132 w2 =localtime(&when);
10133 tz_parse_startend(s_start,w2,&ds);
10134 tz_parse_startend(s_end,w2,&de);
10135 if (ds != de) break;
10139 if (de && !ds) reversed = 1;
10142 isdst = dststart && !dstend;
10143 if (reversed) isdst = dststart || !dstend;
10146 if (dst) *dst = isdst;
10147 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10148 if (isdst) tz = dstzone;
10150 while(isalpha(*tz)) *zone++ = *tz++;
10156 #endif /* !RTL_USES_UTC */
10158 /* my_time(), my_localtime(), my_gmtime()
10159 * By default traffic in UTC time values, using CRTL gmtime() or
10160 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10161 * Note: We need to use these functions even when the CRTL has working
10162 * UTC support, since they also handle C<use vmsish qw(times);>
10164 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
10165 * Modified by Charles Bailey <bailey@newman.upenn.edu>
10168 /*{{{time_t my_time(time_t *timep)*/
10169 time_t Perl_my_time(pTHX_ time_t *timep)
10174 if (gmtime_emulation_type == 0) {
10176 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
10177 /* results of calls to gmtime() and localtime() */
10178 /* for same &base */
10180 gmtime_emulation_type++;
10181 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10182 char off[LNM$C_NAMLENGTH+1];;
10184 gmtime_emulation_type++;
10185 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10186 gmtime_emulation_type++;
10187 utc_offset_secs = 0;
10188 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10190 else { utc_offset_secs = atol(off); }
10192 else { /* We've got a working gmtime() */
10193 struct tm gmt, local;
10196 tm_p = localtime(&base);
10198 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
10199 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10200 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
10201 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
10206 # ifdef VMSISH_TIME
10207 # ifdef RTL_USES_UTC
10208 if (VMSISH_TIME) when = _toloc(when);
10210 if (!VMSISH_TIME) when = _toutc(when);
10213 if (timep != NULL) *timep = when;
10216 } /* end of my_time() */
10220 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10222 Perl_my_gmtime(pTHX_ const time_t *timep)
10228 if (timep == NULL) {
10229 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10232 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10235 # ifdef VMSISH_TIME
10236 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10238 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
10239 return gmtime(&when);
10241 /* CRTL localtime() wants local time as input, so does no tz correction */
10242 rsltmp = localtime(&when);
10243 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
10246 } /* end of my_gmtime() */
10250 /*{{{struct tm *my_localtime(const time_t *timep)*/
10252 Perl_my_localtime(pTHX_ const time_t *timep)
10254 time_t when, whenutc;
10258 if (timep == NULL) {
10259 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10262 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10263 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10266 # ifdef RTL_USES_UTC
10267 # ifdef VMSISH_TIME
10268 if (VMSISH_TIME) when = _toutc(when);
10270 /* CRTL localtime() wants UTC as input, does tz correction itself */
10271 return localtime(&when);
10273 # else /* !RTL_USES_UTC */
10275 # ifdef VMSISH_TIME
10276 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
10277 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
10280 #ifndef RTL_USES_UTC
10281 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
10282 when = whenutc - offset; /* pseudolocal time*/
10285 /* CRTL localtime() wants local time as input, so does no tz correction */
10286 rsltmp = localtime(&when);
10287 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10291 } /* end of my_localtime() */
10294 /* Reset definitions for later calls */
10295 #define gmtime(t) my_gmtime(t)
10296 #define localtime(t) my_localtime(t)
10297 #define time(t) my_time(t)
10300 /* my_utime - update modification/access time of a file
10302 * VMS 7.3 and later implementation
10303 * Only the UTC translation is home-grown. The rest is handled by the
10304 * CRTL utime(), which will take into account the relevant feature
10305 * logicals and ODS-5 volume characteristics for true access times.
10307 * pre VMS 7.3 implementation:
10308 * The calling sequence is identical to POSIX utime(), but under
10309 * VMS with ODS-2, only the modification time is changed; ODS-2 does
10310 * not maintain access times. Restrictions differ from the POSIX
10311 * definition in that the time can be changed as long as the
10312 * caller has permission to execute the necessary IO$_MODIFY $QIO;
10313 * no separate checks are made to insure that the caller is the
10314 * owner of the file or has special privs enabled.
10315 * Code here is based on Joe Meadows' FILE utility.
10319 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10320 * to VMS epoch (01-JAN-1858 00:00:00.00)
10321 * in 100 ns intervals.
10323 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10325 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10326 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10328 #if __CRTL_VER >= 70300000
10329 struct utimbuf utc_utimes, *utc_utimesp;
10331 if (utimes != NULL) {
10332 utc_utimes.actime = utimes->actime;
10333 utc_utimes.modtime = utimes->modtime;
10334 # ifdef VMSISH_TIME
10335 /* If input was local; convert to UTC for sys svc */
10337 utc_utimes.actime = _toutc(utimes->actime);
10338 utc_utimes.modtime = _toutc(utimes->modtime);
10341 utc_utimesp = &utc_utimes;
10344 utc_utimesp = NULL;
10347 return utime(file, utc_utimesp);
10349 #else /* __CRTL_VER < 70300000 */
10353 long int bintime[2], len = 2, lowbit, unixtime,
10354 secscale = 10000000; /* seconds --> 100 ns intervals */
10355 unsigned long int chan, iosb[2], retsts;
10356 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10357 struct FAB myfab = cc$rms_fab;
10358 struct NAM mynam = cc$rms_nam;
10359 #if defined (__DECC) && defined (__VAX)
10360 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10361 * at least through VMS V6.1, which causes a type-conversion warning.
10363 # pragma message save
10364 # pragma message disable cvtdiftypes
10366 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10367 struct fibdef myfib;
10368 #if defined (__DECC) && defined (__VAX)
10369 /* This should be right after the declaration of myatr, but due
10370 * to a bug in VAX DEC C, this takes effect a statement early.
10372 # pragma message restore
10374 /* cast ok for read only parameter */
10375 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10376 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10377 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10379 if (file == NULL || *file == '\0') {
10380 SETERRNO(ENOENT, LIB$_INVARG);
10384 /* Convert to VMS format ensuring that it will fit in 255 characters */
10385 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10386 SETERRNO(ENOENT, LIB$_INVARG);
10389 if (utimes != NULL) {
10390 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
10391 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10392 * Since time_t is unsigned long int, and lib$emul takes a signed long int
10393 * as input, we force the sign bit to be clear by shifting unixtime right
10394 * one bit, then multiplying by an extra factor of 2 in lib$emul().
10396 lowbit = (utimes->modtime & 1) ? secscale : 0;
10397 unixtime = (long int) utimes->modtime;
10398 # ifdef VMSISH_TIME
10399 /* If input was UTC; convert to local for sys svc */
10400 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10402 unixtime >>= 1; secscale <<= 1;
10403 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10404 if (!(retsts & 1)) {
10405 SETERRNO(EVMSERR, retsts);
10408 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10409 if (!(retsts & 1)) {
10410 SETERRNO(EVMSERR, retsts);
10415 /* Just get the current time in VMS format directly */
10416 retsts = sys$gettim(bintime);
10417 if (!(retsts & 1)) {
10418 SETERRNO(EVMSERR, retsts);
10423 myfab.fab$l_fna = vmsspec;
10424 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10425 myfab.fab$l_nam = &mynam;
10426 mynam.nam$l_esa = esa;
10427 mynam.nam$b_ess = (unsigned char) sizeof esa;
10428 mynam.nam$l_rsa = rsa;
10429 mynam.nam$b_rss = (unsigned char) sizeof rsa;
10430 if (decc_efs_case_preserve)
10431 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10433 /* Look for the file to be affected, letting RMS parse the file
10434 * specification for us as well. I have set errno using only
10435 * values documented in the utime() man page for VMS POSIX.
10437 retsts = sys$parse(&myfab,0,0);
10438 if (!(retsts & 1)) {
10439 set_vaxc_errno(retsts);
10440 if (retsts == RMS$_PRV) set_errno(EACCES);
10441 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10442 else set_errno(EVMSERR);
10445 retsts = sys$search(&myfab,0,0);
10446 if (!(retsts & 1)) {
10447 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10448 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10449 set_vaxc_errno(retsts);
10450 if (retsts == RMS$_PRV) set_errno(EACCES);
10451 else if (retsts == RMS$_FNF) set_errno(ENOENT);
10452 else set_errno(EVMSERR);
10456 devdsc.dsc$w_length = mynam.nam$b_dev;
10457 /* cast ok for read only parameter */
10458 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10460 retsts = sys$assign(&devdsc,&chan,0,0);
10461 if (!(retsts & 1)) {
10462 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10463 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10464 set_vaxc_errno(retsts);
10465 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
10466 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
10467 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
10468 else set_errno(EVMSERR);
10472 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10473 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10475 memset((void *) &myfib, 0, sizeof myfib);
10476 #if defined(__DECC) || defined(__DECCXX)
10477 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10478 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10479 /* This prevents the revision time of the file being reset to the current
10480 * time as a result of our IO$_MODIFY $QIO. */
10481 myfib.fib$l_acctl = FIB$M_NORECORD;
10483 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10484 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10485 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10487 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10488 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10489 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10490 _ckvmssts(sys$dassgn(chan));
10491 if (retsts & 1) retsts = iosb[0];
10492 if (!(retsts & 1)) {
10493 set_vaxc_errno(retsts);
10494 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10495 else set_errno(EVMSERR);
10501 #endif /* #if __CRTL_VER >= 70300000 */
10503 } /* end of my_utime() */
10507 * flex_stat, flex_lstat, flex_fstat
10508 * basic stat, but gets it right when asked to stat
10509 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10512 #ifndef _USE_STD_STAT
10513 /* encode_dev packs a VMS device name string into an integer to allow
10514 * simple comparisons. This can be used, for example, to check whether two
10515 * files are located on the same device, by comparing their encoded device
10516 * names. Even a string comparison would not do, because stat() reuses the
10517 * device name buffer for each call; so without encode_dev, it would be
10518 * necessary to save the buffer and use strcmp (this would mean a number of
10519 * changes to the standard Perl code, to say nothing of what a Perl script
10520 * would have to do.
10522 * The device lock id, if it exists, should be unique (unless perhaps compared
10523 * with lock ids transferred from other nodes). We have a lock id if the disk is
10524 * mounted cluster-wide, which is when we tend to get long (host-qualified)
10525 * device names. Thus we use the lock id in preference, and only if that isn't
10526 * available, do we try to pack the device name into an integer (flagged by
10527 * the sign bit (LOCKID_MASK) being set).
10529 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10530 * name and its encoded form, but it seems very unlikely that we will find
10531 * two files on different disks that share the same encoded device names,
10532 * and even more remote that they will share the same file id (if the test
10533 * is to check for the same file).
10535 * A better method might be to use sys$device_scan on the first call, and to
10536 * search for the device, returning an index into the cached array.
10537 * The number returned would be more intelligible.
10538 * This is probably not worth it, and anyway would take quite a bit longer
10539 * on the first call.
10541 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
10542 static mydev_t encode_dev (pTHX_ const char *dev)
10545 unsigned long int f;
10550 if (!dev || !dev[0]) return 0;
10554 struct dsc$descriptor_s dev_desc;
10555 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10557 /* For cluster-mounted disks, the disk lock identifier is unique, so we
10558 can try that first. */
10559 dev_desc.dsc$w_length = strlen (dev);
10560 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
10561 dev_desc.dsc$b_class = DSC$K_CLASS_S;
10562 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
10563 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10564 if (!$VMS_STATUS_SUCCESS(status)) {
10566 case SS$_NOSUCHDEV:
10567 SETERRNO(ENODEV, status);
10573 if (lockid) return (lockid & ~LOCKID_MASK);
10577 /* Otherwise we try to encode the device name */
10581 for (q = dev + strlen(dev); q--; q >= dev) {
10586 else if (isalpha (toupper (*q)))
10587 c= toupper (*q) - 'A' + (char)10;
10589 continue; /* Skip '$'s */
10591 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
10593 enc += f * (unsigned long int) c;
10595 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
10597 } /* end of encode_dev() */
10598 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10599 device_no = encode_dev(aTHX_ devname)
10601 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10602 device_no = new_dev_no
10606 is_null_device(name)
10609 if (decc_bug_devnull != 0) {
10610 if (strncmp("/dev/null", name, 9) == 0)
10613 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10614 The underscore prefix, controller letter, and unit number are
10615 independently optional; for our purposes, the colon punctuation
10616 is not. The colon can be trailed by optional directory and/or
10617 filename, but two consecutive colons indicates a nodename rather
10618 than a device. [pr] */
10619 if (*name == '_') ++name;
10620 if (tolower(*name++) != 'n') return 0;
10621 if (tolower(*name++) != 'l') return 0;
10622 if (tolower(*name) == 'a') ++name;
10623 if (*name == '0') ++name;
10624 return (*name++ == ':') && (*name != ':');
10629 Perl_cando_by_name_int
10630 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10632 static char usrname[L_cuserid];
10633 static struct dsc$descriptor_s usrdsc =
10634 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10635 char vmsname[NAM$C_MAXRSS+1];
10637 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10638 unsigned short int retlen, trnlnm_iter_count;
10639 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10640 union prvdef curprv;
10641 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10642 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10643 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10644 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10645 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10647 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10649 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10651 if (!fname || !*fname) return FALSE;
10652 /* Make sure we expand logical names, since sys$check_access doesn't */
10655 if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10656 fileified = PerlMem_malloc(VMS_MAXRSS);
10657 if (!strpbrk(fname,"/]>:")) {
10658 strcpy(fileified,fname);
10659 trnlnm_iter_count = 0;
10660 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10661 trnlnm_iter_count++;
10662 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10666 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10667 PerlMem_free(fileified);
10670 retlen = namdsc.dsc$w_length = strlen(vmsname);
10671 namdsc.dsc$a_pointer = vmsname;
10672 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10673 vmsname[retlen-1] == ':') {
10674 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10675 namdsc.dsc$w_length = strlen(fileified);
10676 namdsc.dsc$a_pointer = fileified;
10680 retlen = namdsc.dsc$w_length = strlen(fname);
10681 namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10685 case S_IXUSR: case S_IXGRP: case S_IXOTH:
10686 access = ARM$M_EXECUTE;
10687 flags = CHP$M_READ;
10689 case S_IRUSR: case S_IRGRP: case S_IROTH:
10690 access = ARM$M_READ;
10691 flags = CHP$M_READ | CHP$M_USEREADALL;
10693 case S_IWUSR: case S_IWGRP: case S_IWOTH:
10694 access = ARM$M_WRITE;
10695 flags = CHP$M_READ | CHP$M_WRITE;
10697 case S_IDUSR: case S_IDGRP: case S_IDOTH:
10698 access = ARM$M_DELETE;
10699 flags = CHP$M_READ | CHP$M_WRITE;
10702 if (fileified != NULL)
10703 PerlMem_free(fileified);
10707 /* Before we call $check_access, create a user profile with the current
10708 * process privs since otherwise it just uses the default privs from the
10709 * UAF and might give false positives or negatives. This only works on
10710 * VMS versions v6.0 and later since that's when sys$create_user_profile
10711 * became available.
10714 /* get current process privs and username */
10715 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10716 _ckvmssts(iosb[0]);
10718 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10720 /* find out the space required for the profile */
10721 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10722 &usrprodsc.dsc$w_length,0));
10724 /* allocate space for the profile and get it filled in */
10725 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10726 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10727 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10728 &usrprodsc.dsc$w_length,0));
10730 /* use the profile to check access to the file; free profile & analyze results */
10731 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10732 PerlMem_free(usrprodsc.dsc$a_pointer);
10733 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10737 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10741 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
10742 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10743 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10744 set_vaxc_errno(retsts);
10745 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10746 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10747 else set_errno(ENOENT);
10748 if (fileified != NULL)
10749 PerlMem_free(fileified);
10752 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10753 if (fileified != NULL)
10754 PerlMem_free(fileified);
10759 if (fileified != NULL)
10760 PerlMem_free(fileified);
10761 return FALSE; /* Should never get here */
10765 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
10766 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
10767 * subset of the applicable information.
10770 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
10772 return cando_by_name_int
10773 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
10774 } /* end of cando() */
10778 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10780 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10782 return cando_by_name_int(bit, effective, fname, 0);
10784 } /* end of cando_by_name() */
10788 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10790 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10792 if (!fstat(fd,(stat_t *) statbufp)) {
10794 char *vms_filename;
10795 vms_filename = PerlMem_malloc(VMS_MAXRSS);
10796 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
10798 /* Save name for cando by name in VMS format */
10799 cptr = getname(fd, vms_filename, 1);
10801 /* This should not happen, but just in case */
10802 if (cptr == NULL) {
10803 statbufp->st_devnam[0] = 0;
10806 /* Make sure that the saved name fits in 255 characters */
10807 cptr = do_rmsexpand
10809 statbufp->st_devnam,
10812 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
10816 statbufp->st_devnam[0] = 0;
10818 PerlMem_free(vms_filename);
10820 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10822 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10824 # ifdef RTL_USES_UTC
10825 # ifdef VMSISH_TIME
10827 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10828 statbufp->st_atime = _toloc(statbufp->st_atime);
10829 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10833 # ifdef VMSISH_TIME
10834 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10838 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10839 statbufp->st_atime = _toutc(statbufp->st_atime);
10840 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10847 } /* end of flex_fstat() */
10850 #if !defined(__VAX) && __CRTL_VER >= 80200000
10858 #define lstat(_x, _y) stat(_x, _y)
10861 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
10864 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10866 char fileified[VMS_MAXRSS];
10867 char temp_fspec[VMS_MAXRSS];
10870 int saved_errno, saved_vaxc_errno;
10872 if (!fspec) return retval;
10873 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10874 strcpy(temp_fspec, fspec);
10876 if (decc_bug_devnull != 0) {
10877 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10878 memset(statbufp,0,sizeof *statbufp);
10879 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
10880 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10881 statbufp->st_uid = 0x00010001;
10882 statbufp->st_gid = 0x0001;
10883 time((time_t *)&statbufp->st_mtime);
10884 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10889 /* Try for a directory name first. If fspec contains a filename without
10890 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10891 * and sea:[wine.dark]water. exist, we prefer the directory here.
10892 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10893 * not sea:[wine.dark]., if the latter exists. If the intended target is
10894 * the file with null type, specify this by calling flex_stat() with
10895 * a '.' at the end of fspec.
10897 * If we are in Posix filespec mode, accept the filename as is.
10899 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10900 if (decc_posix_compliant_pathnames == 0) {
10902 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
10903 if (lstat_flag == 0)
10904 retval = stat(fileified,(stat_t *) statbufp);
10906 retval = lstat(fileified,(stat_t *) statbufp);
10907 save_spec = fileified;
10910 if (lstat_flag == 0)
10911 retval = stat(temp_fspec,(stat_t *) statbufp);
10913 retval = lstat(temp_fspec,(stat_t *) statbufp);
10914 save_spec = temp_fspec;
10916 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10918 if (lstat_flag == 0)
10919 retval = stat(temp_fspec,(stat_t *) statbufp);
10921 retval = lstat(temp_fspec,(stat_t *) statbufp);
10922 save_spec = temp_fspec;
10927 cptr = do_rmsexpand
10928 (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
10930 statbufp->st_devnam[0] = 0;
10932 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10934 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10935 # ifdef RTL_USES_UTC
10936 # ifdef VMSISH_TIME
10938 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10939 statbufp->st_atime = _toloc(statbufp->st_atime);
10940 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10944 # ifdef VMSISH_TIME
10945 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10949 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10950 statbufp->st_atime = _toutc(statbufp->st_atime);
10951 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10955 /* If we were successful, leave errno where we found it */
10956 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10959 } /* end of flex_stat_int() */
10962 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10964 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10966 return flex_stat_int(fspec, statbufp, 0);
10970 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10972 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10974 return flex_stat_int(fspec, statbufp, 1);
10979 /*{{{char *my_getlogin()*/
10980 /* VMS cuserid == Unix getlogin, except calling sequence */
10984 static char user[L_cuserid];
10985 return cuserid(user);
10990 /* rmscopy - copy a file using VMS RMS routines
10992 * Copies contents and attributes of spec_in to spec_out, except owner
10993 * and protection information. Name and type of spec_in are used as
10994 * defaults for spec_out. The third parameter specifies whether rmscopy()
10995 * should try to propagate timestamps from the input file to the output file.
10996 * If it is less than 0, no timestamps are preserved. If it is 0, then
10997 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
10998 * propagated to the output file at creation iff the output file specification
10999 * did not contain an explicit name or type, and the revision date is always
11000 * updated at the end of the copy operation. If it is greater than 0, then
11001 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11002 * other than the revision date should be propagated, and bit 1 indicates
11003 * that the revision date should be propagated.
11005 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11007 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11008 * Incorporates, with permission, some code from EZCOPY by Tim Adye
11009 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
11010 * as part of the Perl standard distribution under the terms of the
11011 * GNU General Public License or the Perl Artistic License. Copies
11012 * of each may be found in the Perl standard distribution.
11014 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11016 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11018 char *vmsin, * vmsout, *esa, *esa_out,
11020 unsigned long int i, sts, sts2;
11022 struct FAB fab_in, fab_out;
11023 struct RAB rab_in, rab_out;
11024 rms_setup_nam(nam);
11025 rms_setup_nam(nam_out);
11026 struct XABDAT xabdat;
11027 struct XABFHC xabfhc;
11028 struct XABRDT xabrdt;
11029 struct XABSUM xabsum;
11031 vmsin = PerlMem_malloc(VMS_MAXRSS);
11032 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11033 vmsout = PerlMem_malloc(VMS_MAXRSS);
11034 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11035 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11036 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11037 PerlMem_free(vmsin);
11038 PerlMem_free(vmsout);
11039 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11043 esa = PerlMem_malloc(VMS_MAXRSS);
11044 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11045 fab_in = cc$rms_fab;
11046 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11047 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11048 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11049 fab_in.fab$l_fop = FAB$M_SQO;
11050 rms_bind_fab_nam(fab_in, nam);
11051 fab_in.fab$l_xab = (void *) &xabdat;
11053 rsa = PerlMem_malloc(VMS_MAXRSS);
11054 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11055 rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11056 rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11057 rms_nam_esl(nam) = 0;
11058 rms_nam_rsl(nam) = 0;
11059 rms_nam_esll(nam) = 0;
11060 rms_nam_rsll(nam) = 0;
11061 #ifdef NAM$M_NO_SHORT_UPCASE
11062 if (decc_efs_case_preserve)
11063 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11066 xabdat = cc$rms_xabdat; /* To get creation date */
11067 xabdat.xab$l_nxt = (void *) &xabfhc;
11069 xabfhc = cc$rms_xabfhc; /* To get record length */
11070 xabfhc.xab$l_nxt = (void *) &xabsum;
11072 xabsum = cc$rms_xabsum; /* To get key and area information */
11074 if (!((sts = sys$open(&fab_in)) & 1)) {
11075 PerlMem_free(vmsin);
11076 PerlMem_free(vmsout);
11079 set_vaxc_errno(sts);
11081 case RMS$_FNF: case RMS$_DNF:
11082 set_errno(ENOENT); break;
11084 set_errno(ENOTDIR); break;
11086 set_errno(ENODEV); break;
11088 set_errno(EINVAL); break;
11090 set_errno(EACCES); break;
11092 set_errno(EVMSERR);
11099 fab_out.fab$w_ifi = 0;
11100 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11101 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11102 fab_out.fab$l_fop = FAB$M_SQO;
11103 rms_bind_fab_nam(fab_out, nam_out);
11104 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11105 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11106 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11107 esa_out = PerlMem_malloc(VMS_MAXRSS);
11108 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11109 rms_set_rsa(nam_out, NULL, 0);
11110 rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11112 if (preserve_dates == 0) { /* Act like DCL COPY */
11113 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11114 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
11115 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11116 PerlMem_free(vmsin);
11117 PerlMem_free(vmsout);
11120 PerlMem_free(esa_out);
11121 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11122 set_vaxc_errno(sts);
11125 fab_out.fab$l_xab = (void *) &xabdat;
11126 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11127 preserve_dates = 1;
11129 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
11130 preserve_dates =0; /* bitmask from this point forward */
11132 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11133 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11134 PerlMem_free(vmsin);
11135 PerlMem_free(vmsout);
11138 PerlMem_free(esa_out);
11139 set_vaxc_errno(sts);
11142 set_errno(ENOENT); break;
11144 set_errno(ENOTDIR); break;
11146 set_errno(ENODEV); break;
11148 set_errno(EINVAL); break;
11150 set_errno(EACCES); break;
11152 set_errno(EVMSERR);
11156 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
11157 if (preserve_dates & 2) {
11158 /* sys$close() will process xabrdt, not xabdat */
11159 xabrdt = cc$rms_xabrdt;
11161 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11163 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11164 * is unsigned long[2], while DECC & VAXC use a struct */
11165 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11167 fab_out.fab$l_xab = (void *) &xabrdt;
11170 ubf = PerlMem_malloc(32256);
11171 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11172 rab_in = cc$rms_rab;
11173 rab_in.rab$l_fab = &fab_in;
11174 rab_in.rab$l_rop = RAB$M_BIO;
11175 rab_in.rab$l_ubf = ubf;
11176 rab_in.rab$w_usz = 32256;
11177 if (!((sts = sys$connect(&rab_in)) & 1)) {
11178 sys$close(&fab_in); sys$close(&fab_out);
11179 PerlMem_free(vmsin);
11180 PerlMem_free(vmsout);
11184 PerlMem_free(esa_out);
11185 set_errno(EVMSERR); set_vaxc_errno(sts);
11189 rab_out = cc$rms_rab;
11190 rab_out.rab$l_fab = &fab_out;
11191 rab_out.rab$l_rbf = ubf;
11192 if (!((sts = sys$connect(&rab_out)) & 1)) {
11193 sys$close(&fab_in); sys$close(&fab_out);
11194 PerlMem_free(vmsin);
11195 PerlMem_free(vmsout);
11199 PerlMem_free(esa_out);
11200 set_errno(EVMSERR); set_vaxc_errno(sts);
11204 while ((sts = sys$read(&rab_in))) { /* always true */
11205 if (sts == RMS$_EOF) break;
11206 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11207 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11208 sys$close(&fab_in); sys$close(&fab_out);
11209 PerlMem_free(vmsin);
11210 PerlMem_free(vmsout);
11214 PerlMem_free(esa_out);
11215 set_errno(EVMSERR); set_vaxc_errno(sts);
11221 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
11222 sys$close(&fab_in); sys$close(&fab_out);
11223 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11225 PerlMem_free(vmsin);
11226 PerlMem_free(vmsout);
11230 PerlMem_free(esa_out);
11231 set_errno(EVMSERR); set_vaxc_errno(sts);
11235 PerlMem_free(vmsin);
11236 PerlMem_free(vmsout);
11240 PerlMem_free(esa_out);
11243 } /* end of rmscopy() */
11247 /*** The following glue provides 'hooks' to make some of the routines
11248 * from this file available from Perl. These routines are sufficiently
11249 * basic, and are required sufficiently early in the build process,
11250 * that's it's nice to have them available to miniperl as well as the
11251 * full Perl, so they're set up here instead of in an extension. The
11252 * Perl code which handles importation of these names into a given
11253 * package lives in [.VMS]Filespec.pm in @INC.
11257 rmsexpand_fromperl(pTHX_ CV *cv)
11260 char *fspec, *defspec = NULL, *rslt;
11262 int fs_utf8, dfs_utf8;
11266 if (!items || items > 2)
11267 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11268 fspec = SvPV(ST(0),n_a);
11269 fs_utf8 = SvUTF8(ST(0));
11270 if (!fspec || !*fspec) XSRETURN_UNDEF;
11272 defspec = SvPV(ST(1),n_a);
11273 dfs_utf8 = SvUTF8(ST(1));
11275 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11276 ST(0) = sv_newmortal();
11277 if (rslt != NULL) {
11278 sv_usepvn(ST(0),rslt,strlen(rslt));
11287 vmsify_fromperl(pTHX_ CV *cv)
11294 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11295 utf8_fl = SvUTF8(ST(0));
11296 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11297 ST(0) = sv_newmortal();
11298 if (vmsified != NULL) {
11299 sv_usepvn(ST(0),vmsified,strlen(vmsified));
11308 unixify_fromperl(pTHX_ CV *cv)
11315 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11316 utf8_fl = SvUTF8(ST(0));
11317 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11318 ST(0) = sv_newmortal();
11319 if (unixified != NULL) {
11320 sv_usepvn(ST(0),unixified,strlen(unixified));
11329 fileify_fromperl(pTHX_ CV *cv)
11336 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11337 utf8_fl = SvUTF8(ST(0));
11338 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11339 ST(0) = sv_newmortal();
11340 if (fileified != NULL) {
11341 sv_usepvn(ST(0),fileified,strlen(fileified));
11350 pathify_fromperl(pTHX_ CV *cv)
11357 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11358 utf8_fl = SvUTF8(ST(0));
11359 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11360 ST(0) = sv_newmortal();
11361 if (pathified != NULL) {
11362 sv_usepvn(ST(0),pathified,strlen(pathified));
11371 vmspath_fromperl(pTHX_ CV *cv)
11378 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11379 utf8_fl = SvUTF8(ST(0));
11380 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11381 ST(0) = sv_newmortal();
11382 if (vmspath != NULL) {
11383 sv_usepvn(ST(0),vmspath,strlen(vmspath));
11392 unixpath_fromperl(pTHX_ CV *cv)
11399 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11400 utf8_fl = SvUTF8(ST(0));
11401 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11402 ST(0) = sv_newmortal();
11403 if (unixpath != NULL) {
11404 sv_usepvn(ST(0),unixpath,strlen(unixpath));
11413 candelete_fromperl(pTHX_ CV *cv)
11421 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11423 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11424 Newx(fspec, VMS_MAXRSS, char);
11425 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11426 if (SvTYPE(mysv) == SVt_PVGV) {
11427 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11428 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11436 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11437 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11444 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11450 rmscopy_fromperl(pTHX_ CV *cv)
11453 char *inspec, *outspec, *inp, *outp;
11455 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11456 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11457 unsigned long int sts;
11462 if (items < 2 || items > 3)
11463 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11465 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11466 Newx(inspec, VMS_MAXRSS, char);
11467 if (SvTYPE(mysv) == SVt_PVGV) {
11468 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11469 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11477 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11478 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11484 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11485 Newx(outspec, VMS_MAXRSS, char);
11486 if (SvTYPE(mysv) == SVt_PVGV) {
11487 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11488 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11497 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11498 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11505 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11507 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11513 /* The mod2fname is limited to shorter filenames by design, so it should
11514 * not be modified to support longer EFS pathnames
11517 mod2fname(pTHX_ CV *cv)
11520 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11521 workbuff[NAM$C_MAXRSS*1 + 1];
11522 int total_namelen = 3, counter, num_entries;
11523 /* ODS-5 ups this, but we want to be consistent, so... */
11524 int max_name_len = 39;
11525 AV *in_array = (AV *)SvRV(ST(0));
11527 num_entries = av_len(in_array);
11529 /* All the names start with PL_. */
11530 strcpy(ultimate_name, "PL_");
11532 /* Clean up our working buffer */
11533 Zero(work_name, sizeof(work_name), char);
11535 /* Run through the entries and build up a working name */
11536 for(counter = 0; counter <= num_entries; counter++) {
11537 /* If it's not the first name then tack on a __ */
11539 strcat(work_name, "__");
11541 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11545 /* Check to see if we actually have to bother...*/
11546 if (strlen(work_name) + 3 <= max_name_len) {
11547 strcat(ultimate_name, work_name);
11549 /* It's too darned big, so we need to go strip. We use the same */
11550 /* algorithm as xsubpp does. First, strip out doubled __ */
11551 char *source, *dest, last;
11554 for (source = work_name; *source; source++) {
11555 if (last == *source && last == '_') {
11561 /* Go put it back */
11562 strcpy(work_name, workbuff);
11563 /* Is it still too big? */
11564 if (strlen(work_name) + 3 > max_name_len) {
11565 /* Strip duplicate letters */
11568 for (source = work_name; *source; source++) {
11569 if (last == toupper(*source)) {
11573 last = toupper(*source);
11575 strcpy(work_name, workbuff);
11578 /* Is it *still* too big? */
11579 if (strlen(work_name) + 3 > max_name_len) {
11580 /* Too bad, we truncate */
11581 work_name[max_name_len - 2] = 0;
11583 strcat(ultimate_name, work_name);
11586 /* Okay, return it */
11587 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11592 hushexit_fromperl(pTHX_ CV *cv)
11597 VMSISH_HUSHED = SvTRUE(ST(0));
11599 ST(0) = boolSV(VMSISH_HUSHED);
11605 Perl_vms_start_glob
11606 (pTHX_ SV *tmpglob,
11610 struct vs_str_st *rslt;
11614 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11617 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11618 struct dsc$descriptor_vs rsdsc;
11619 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11620 unsigned long hasver = 0, isunix = 0;
11621 unsigned long int lff_flags = 0;
11624 #ifdef VMS_LONGNAME_SUPPORT
11625 lff_flags = LIB$M_FIL_LONG_NAMES;
11627 /* The Newx macro will not allow me to assign a smaller array
11628 * to the rslt pointer, so we will assign it to the begin char pointer
11629 * and then copy the value into the rslt pointer.
11631 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11632 rslt = (struct vs_str_st *)begin;
11634 rstr = &rslt->str[0];
11635 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11636 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11637 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11638 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11640 Newx(vmsspec, VMS_MAXRSS, char);
11642 /* We could find out if there's an explicit dev/dir or version
11643 by peeking into lib$find_file's internal context at
11644 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11645 but that's unsupported, so I don't want to do it now and
11646 have it bite someone in the future. */
11647 /* Fix-me: vms_split_path() is the only way to do this, the
11648 existing method will fail with many legal EFS or UNIX specifications
11651 cp = SvPV(tmpglob,i);
11654 if (cp[i] == ';') hasver = 1;
11655 if (cp[i] == '.') {
11656 if (sts) hasver = 1;
11659 if (cp[i] == '/') {
11660 hasdir = isunix = 1;
11663 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11668 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11671 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11672 if (!stat_sts && S_ISDIR(st.st_mode)) {
11673 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11674 ok = (wilddsc.dsc$a_pointer != NULL);
11677 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11678 ok = (wilddsc.dsc$a_pointer != NULL);
11681 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11683 /* If not extended character set, replace ? with % */
11684 /* With extended character set, ? is a wildcard single character */
11685 if (!decc_efs_case_preserve) {
11686 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11687 if (*cp == '?') *cp = '%';
11690 while (ok && $VMS_STATUS_SUCCESS(sts)) {
11691 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11692 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11694 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11695 &dfltdsc,NULL,&rms_sts,&lff_flags);
11696 if (!$VMS_STATUS_SUCCESS(sts))
11699 /* with varying string, 1st word of buffer contains result length */
11700 rstr[rslt->length] = '\0';
11702 /* Find where all the components are */
11703 v_sts = vms_split_path
11718 /* If no version on input, truncate the version on output */
11719 if (!hasver && (vs_len > 0)) {
11723 /* No version & a null extension on UNIX handling */
11724 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
11730 if (!decc_efs_case_preserve) {
11731 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
11735 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
11739 /* Start with the name */
11742 strcat(begin,"\n");
11743 ok = (PerlIO_puts(tmpfp,begin) != EOF);
11745 if (cxt) (void)lib$find_file_end(&cxt);
11746 if (ok && sts != RMS$_NMF &&
11747 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
11750 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
11752 PerlIO_close(tmpfp);
11756 PerlIO_rewind(tmpfp);
11757 IoTYPE(io) = IoTYPE_RDONLY;
11758 IoIFP(io) = fp = tmpfp;
11759 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
11769 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
11772 vms_realpath_fromperl(pTHX_ CV *cv)
11775 char *fspec, *rslt_spec, *rslt;
11778 if (!items || items != 1)
11779 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11781 fspec = SvPV(ST(0),n_a);
11782 if (!fspec || !*fspec) XSRETURN_UNDEF;
11784 Newx(rslt_spec, VMS_MAXRSS + 1, char);
11785 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
11786 ST(0) = sv_newmortal();
11788 sv_usepvn(ST(0),rslt,strlen(rslt));
11790 Safefree(rslt_spec);
11795 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11796 int do_vms_case_tolerant(void);
11799 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11802 ST(0) = boolSV(do_vms_case_tolerant());
11808 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11809 struct interp_intern *dst)
11811 memcpy(dst,src,sizeof(struct interp_intern));
11815 Perl_sys_intern_clear(pTHX)
11820 Perl_sys_intern_init(pTHX)
11822 unsigned int ix = RAND_MAX;
11827 /* fix me later to track running under GNV */
11828 /* this allows some limited testing */
11829 MY_POSIX_EXIT = decc_filename_unix_report;
11832 MY_INV_RAND_MAX = 1./x;
11836 init_os_extras(void)
11839 char* file = __FILE__;
11840 if (decc_disable_to_vms_logname_translation) {
11841 no_translate_barewords = TRUE;
11843 no_translate_barewords = FALSE;
11846 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11847 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11848 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11849 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11850 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11851 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11852 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11853 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11854 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11855 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11856 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11858 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11860 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11861 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11864 store_pipelocs(aTHX); /* will redo any earlier attempts */
11871 #if __CRTL_VER == 80200000
11872 /* This missed getting in to the DECC SDK for 8.2 */
11873 char *realpath(const char *file_name, char * resolved_name, ...);
11876 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11877 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11878 * The perl fallback routine to provide realpath() is not as efficient
11882 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11884 return realpath(filespec, outbuf);
11888 /* External entry points */
11889 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11890 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
11892 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11897 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11898 /* case_tolerant */
11900 /*{{{int do_vms_case_tolerant(void)*/
11901 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11902 * controlled by a process setting.
11904 int do_vms_case_tolerant(void)
11906 return vms_process_case_tolerant;
11909 /* External entry points */
11910 int Perl_vms_case_tolerant(void)
11911 { return do_vms_case_tolerant(); }
11913 int Perl_vms_case_tolerant(void)
11914 { return vms_process_case_tolerant; }
11918 /* Start of DECC RTL Feature handling */
11920 static int sys_trnlnm
11921 (const char * logname,
11925 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11926 const unsigned long attr = LNM$M_CASE_BLIND;
11927 struct dsc$descriptor_s name_dsc;
11929 unsigned short result;
11930 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11933 name_dsc.dsc$w_length = strlen(logname);
11934 name_dsc.dsc$a_pointer = (char *)logname;
11935 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11936 name_dsc.dsc$b_class = DSC$K_CLASS_S;
11938 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11940 if ($VMS_STATUS_SUCCESS(status)) {
11942 /* Null terminate and return the string */
11943 /*--------------------------------------*/
11950 static int sys_crelnm
11951 (const char * logname,
11952 const char * value)
11955 const char * proc_table = "LNM$PROCESS_TABLE";
11956 struct dsc$descriptor_s proc_table_dsc;
11957 struct dsc$descriptor_s logname_dsc;
11958 struct itmlst_3 item_list[2];
11960 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11961 proc_table_dsc.dsc$w_length = strlen(proc_table);
11962 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11963 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11965 logname_dsc.dsc$a_pointer = (char *) logname;
11966 logname_dsc.dsc$w_length = strlen(logname);
11967 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11968 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11970 item_list[0].buflen = strlen(value);
11971 item_list[0].itmcode = LNM$_STRING;
11972 item_list[0].bufadr = (char *)value;
11973 item_list[0].retlen = NULL;
11975 item_list[1].buflen = 0;
11976 item_list[1].itmcode = 0;
11978 ret_val = sys$crelnm
11980 (const struct dsc$descriptor_s *)&proc_table_dsc,
11981 (const struct dsc$descriptor_s *)&logname_dsc,
11983 (const struct item_list_3 *) item_list);
11988 /* C RTL Feature settings */
11990 static int set_features
11991 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
11992 int (* cli_routine)(void), /* Not documented */
11993 void *image_info) /* Not documented */
12000 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12001 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12002 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12003 unsigned long case_perm;
12004 unsigned long case_image;
12007 /* Allow an exception to bring Perl into the VMS debugger */
12008 vms_debug_on_exception = 0;
12009 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12010 if ($VMS_STATUS_SUCCESS(status)) {
12011 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12012 vms_debug_on_exception = 1;
12014 vms_debug_on_exception = 0;
12017 /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12018 vms_vtf7_filenames = 0;
12019 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12020 if ($VMS_STATUS_SUCCESS(status)) {
12021 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12022 vms_vtf7_filenames = 1;
12024 vms_vtf7_filenames = 0;
12027 /* Dectect running under GNV Bash or other UNIX like shell */
12028 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12029 gnv_unix_shell = 0;
12030 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12031 if ($VMS_STATUS_SUCCESS(status)) {
12032 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12033 gnv_unix_shell = 1;
12034 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12035 set_feature_default("DECC$EFS_CHARSET", 1);
12036 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12037 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12038 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12039 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12042 gnv_unix_shell = 0;
12046 /* hacks to see if known bugs are still present for testing */
12048 /* Readdir is returning filenames in VMS syntax always */
12049 decc_bug_readdir_efs1 = 1;
12050 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12051 if ($VMS_STATUS_SUCCESS(status)) {
12052 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12053 decc_bug_readdir_efs1 = 1;
12055 decc_bug_readdir_efs1 = 0;
12058 /* PCP mode requires creating /dev/null special device file */
12059 decc_bug_devnull = 0;
12060 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12061 if ($VMS_STATUS_SUCCESS(status)) {
12062 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12063 decc_bug_devnull = 1;
12065 decc_bug_devnull = 0;
12068 /* fgetname returning a VMS name in UNIX mode */
12069 decc_bug_fgetname = 1;
12070 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12071 if ($VMS_STATUS_SUCCESS(status)) {
12072 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12073 decc_bug_fgetname = 1;
12075 decc_bug_fgetname = 0;
12078 /* UNIX directory names with no paths are broken in a lot of places */
12079 decc_dir_barename = 1;
12080 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12081 if ($VMS_STATUS_SUCCESS(status)) {
12082 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12083 decc_dir_barename = 1;
12085 decc_dir_barename = 0;
12088 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12089 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12091 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12092 if (decc_disable_to_vms_logname_translation < 0)
12093 decc_disable_to_vms_logname_translation = 0;
12096 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12098 decc_efs_case_preserve = decc$feature_get_value(s, 1);
12099 if (decc_efs_case_preserve < 0)
12100 decc_efs_case_preserve = 0;
12103 s = decc$feature_get_index("DECC$EFS_CHARSET");
12105 decc_efs_charset = decc$feature_get_value(s, 1);
12106 if (decc_efs_charset < 0)
12107 decc_efs_charset = 0;
12110 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12112 decc_filename_unix_report = decc$feature_get_value(s, 1);
12113 if (decc_filename_unix_report > 0)
12114 decc_filename_unix_report = 1;
12116 decc_filename_unix_report = 0;
12119 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12121 decc_filename_unix_only = decc$feature_get_value(s, 1);
12122 if (decc_filename_unix_only > 0) {
12123 decc_filename_unix_only = 1;
12126 decc_filename_unix_only = 0;
12130 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12132 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12133 if (decc_filename_unix_no_version < 0)
12134 decc_filename_unix_no_version = 0;
12137 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12139 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12140 if (decc_readdir_dropdotnotype < 0)
12141 decc_readdir_dropdotnotype = 0;
12144 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12145 if ($VMS_STATUS_SUCCESS(status)) {
12146 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12148 dflt = decc$feature_get_value(s, 4);
12150 decc_disable_posix_root = decc$feature_get_value(s, 1);
12151 if (decc_disable_posix_root <= 0) {
12152 decc$feature_set_value(s, 1, 1);
12153 decc_disable_posix_root = 1;
12157 /* Traditionally Perl assumes this is off */
12158 decc_disable_posix_root = 1;
12159 decc$feature_set_value(s, 1, 1);
12164 #if __CRTL_VER >= 80200000
12165 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12167 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12168 if (decc_posix_compliant_pathnames < 0)
12169 decc_posix_compliant_pathnames = 0;
12170 if (decc_posix_compliant_pathnames > 4)
12171 decc_posix_compliant_pathnames = 0;
12176 status = sys_trnlnm
12177 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12178 if ($VMS_STATUS_SUCCESS(status)) {
12179 val_str[0] = _toupper(val_str[0]);
12180 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12181 decc_disable_to_vms_logname_translation = 1;
12186 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12187 if ($VMS_STATUS_SUCCESS(status)) {
12188 val_str[0] = _toupper(val_str[0]);
12189 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12190 decc_efs_case_preserve = 1;
12195 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12196 if ($VMS_STATUS_SUCCESS(status)) {
12197 val_str[0] = _toupper(val_str[0]);
12198 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12199 decc_filename_unix_report = 1;
12202 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12203 if ($VMS_STATUS_SUCCESS(status)) {
12204 val_str[0] = _toupper(val_str[0]);
12205 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12206 decc_filename_unix_only = 1;
12207 decc_filename_unix_report = 1;
12210 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12211 if ($VMS_STATUS_SUCCESS(status)) {
12212 val_str[0] = _toupper(val_str[0]);
12213 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12214 decc_filename_unix_no_version = 1;
12217 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12218 if ($VMS_STATUS_SUCCESS(status)) {
12219 val_str[0] = _toupper(val_str[0]);
12220 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12221 decc_readdir_dropdotnotype = 1;
12226 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12228 /* Report true case tolerance */
12229 /*----------------------------*/
12230 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12231 if (!$VMS_STATUS_SUCCESS(status))
12232 case_perm = PPROP$K_CASE_BLIND;
12233 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12234 if (!$VMS_STATUS_SUCCESS(status))
12235 case_image = PPROP$K_CASE_BLIND;
12236 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12237 (case_image == PPROP$K_CASE_SENSITIVE))
12238 vms_process_case_tolerant = 0;
12243 /* CRTL can be initialized past this point, but not before. */
12244 /* DECC$CRTL_INIT(); */
12250 /* DECC dependent attributes */
12251 #if __DECC_VER < 60560002
12253 #define not_executable
12255 #define relative ,rel
12256 #define not_executable ,noexe
12259 #pragma extern_model save
12260 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12262 const __align (LONGWORD) int spare[8] = {0};
12263 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
12266 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
12267 nowrt,noshr relative not_executable
12269 const long vms_cc_features = (const long)set_features;
12272 ** Force a reference to LIB$INITIALIZE to ensure it
12273 ** exists in the image.
12275 int lib$initialize(void);
12277 #pragma extern_model strict_refdef
12279 int lib_init_ref = (int) lib$initialize;
12282 #pragma extern_model restore