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>
51 /* Set the maximum filespec size here as it is larger for EFS file
53 * Not fully implemented at this time because the larger size
54 * will likely impact the stack local storage requirements of
55 * threaded code, and probably cause hard to diagnose failures.
56 * To implement the larger sizes, all places where filename
57 * storage is put on the stack need to be changed to use
58 * New()/SafeFree() instead.
63 #define VMS_MAXRSS NAML$C_MAXRSS+1
64 #ifndef VMS_LONGNAME_SUPPORT
65 #define VMS_LONGNAME_SUPPORT 1
66 #endif /* VMS_LONGNAME_SUPPORT */
67 #endif /* NAM$L_C_MAXRSS */
68 #endif /* VMS_MAXRSS */
71 /* temporary hack until support is complete */
72 #ifdef VMS_LONGNAME_SUPPORT
73 #undef VMS_LONGNAME_SUPPORT
76 /* end of temporary hack until support is complete */
79 #define VMS_MAXRSS NAM$C_MAXRSS
82 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
83 int decc$feature_get_index(const char *name);
84 char* decc$feature_get_name(int index);
85 int decc$feature_get_value(int index, int mode);
86 int decc$feature_set_value(int index, int mode, int value);
91 #if __CRTL_VER >= 70300000 && !defined(__VAX)
93 static int set_feature_default(const char *name, int value)
98 index = decc$feature_get_index(name);
100 status = decc$feature_set_value(index, 1, value);
101 if (index == -1 || (status == -1)) {
105 status = decc$feature_get_value(index, 1);
106 if (status != value) {
114 /* Older versions of ssdef.h don't have these */
115 #ifndef SS$_INVFILFOROP
116 # define SS$_INVFILFOROP 3930
118 #ifndef SS$_NOSUCHOBJECT
119 # define SS$_NOSUCHOBJECT 2696
122 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
123 #define PERLIO_NOT_STDIO 0
125 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
126 * code below needs to get to the underlying CRTL routines. */
127 #define DONT_MASK_RTL_CALLS
131 /* Anticipating future expansion in lexical warnings . . . */
132 #ifndef WARN_INTERNAL
133 # define WARN_INTERNAL WARN_MISC
136 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
137 # define RTL_USES_UTC 1
141 /* gcc's header files don't #define direct access macros
142 * corresponding to VAXC's variant structs */
144 # define uic$v_format uic$r_uic_form.uic$v_format
145 # define uic$v_group uic$r_uic_form.uic$v_group
146 # define uic$v_member uic$r_uic_form.uic$v_member
147 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
148 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
149 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
150 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
153 #if defined(NEED_AN_H_ERRNO)
158 #pragma message disable pragma
159 #pragma member_alignment save
160 #pragma nomember_alignment longword
162 #pragma message disable misalgndmem
165 unsigned short int buflen;
166 unsigned short int itmcode;
168 unsigned short int *retlen;
171 #pragma message restore
172 #pragma member_alignment restore
175 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
176 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
177 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
178 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
179 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
180 #define do_vms_realpath(a,b) mp_do_vms_realpath(aTHX_ a,b)
181 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
182 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
183 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
184 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
185 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
187 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
188 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
189 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
190 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
192 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
193 #define PERL_LNM_MAX_ALLOWED_INDEX 127
195 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
196 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
199 #define PERL_LNM_MAX_ITER 10
201 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
202 #if __CRTL_VER >= 70302000 && !defined(__VAX)
203 #define MAX_DCL_SYMBOL (8192)
204 #define MAX_DCL_LINE_LENGTH (4096 - 4)
206 #define MAX_DCL_SYMBOL (1024)
207 #define MAX_DCL_LINE_LENGTH (1024 - 4)
210 static char *__mystrtolower(char *str)
212 if (str) for (; *str; ++str) *str= tolower(*str);
216 static struct dsc$descriptor_s fildevdsc =
217 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
218 static struct dsc$descriptor_s crtlenvdsc =
219 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
220 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
221 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
222 static struct dsc$descriptor_s **env_tables = defenv;
223 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
225 /* True if we shouldn't treat barewords as logicals during directory */
227 static int no_translate_barewords;
230 static int tz_updated = 1;
233 /* DECC Features that may need to affect how Perl interprets
234 * displays filename information
236 static int decc_disable_to_vms_logname_translation = 1;
237 static int decc_disable_posix_root = 1;
238 int decc_efs_case_preserve = 0;
239 static int decc_efs_charset = 0;
240 static int decc_filename_unix_no_version = 0;
241 static int decc_filename_unix_only = 0;
242 int decc_filename_unix_report = 0;
243 int decc_posix_compliant_pathnames = 0;
244 int decc_readdir_dropdotnotype = 0;
245 static int vms_process_case_tolerant = 1;
247 /* bug workarounds if needed */
248 int decc_bug_readdir_efs1 = 0;
249 int decc_bug_devnull = 0;
250 int decc_bug_fgetname = 0;
251 int decc_dir_barename = 0;
253 /* Is this a UNIX file specification?
254 * No longer a simple check with EFS file specs
255 * For now, not a full check, but need to
256 * handle POSIX ^UP^ specifications
257 * Fixing to handle ^/ cases would require
258 * changes to many other conversion routines.
261 static is_unix_filespec(const char *path)
267 if (strncmp(path,"\"^UP^",5) != 0) {
268 pch1 = strchr(path, '/');
273 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
274 if (decc_filename_unix_report || decc_filename_unix_only) {
275 if (strcmp(path,".") == 0)
285 * Routine to retrieve the maximum equivalence index for an input
286 * logical name. Some calls to this routine have no knowledge if
287 * the variable is a logical or not. So on error we return a max
290 /*{{{int my_maxidx(const char *lnm) */
292 my_maxidx(const char *lnm)
296 int attr = LNM$M_CASE_BLIND;
297 struct dsc$descriptor lnmdsc;
298 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
301 lnmdsc.dsc$w_length = strlen(lnm);
302 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
303 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
304 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
306 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
307 if ((status & 1) == 0)
314 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
316 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
317 struct dsc$descriptor_s **tabvec, unsigned long int flags)
320 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
321 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
322 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
324 unsigned char acmode;
325 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
326 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
327 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
328 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
330 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
331 #if defined(PERL_IMPLICIT_CONTEXT)
334 aTHX = PERL_GET_INTERP;
340 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
341 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
343 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
344 *cp2 = _toupper(*cp1);
345 if (cp1 - lnm > LNM$C_NAMLENGTH) {
346 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
350 lnmdsc.dsc$w_length = cp1 - lnm;
351 lnmdsc.dsc$a_pointer = uplnm;
352 uplnm[lnmdsc.dsc$w_length] = '\0';
353 secure = flags & PERL__TRNENV_SECURE;
354 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
355 if (!tabvec || !*tabvec) tabvec = env_tables;
357 for (curtab = 0; tabvec[curtab]; curtab++) {
358 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
359 if (!ivenv && !secure) {
364 Perl_warn(aTHX_ "Can't read CRTL environ\n");
367 retsts = SS$_NOLOGNAM;
368 for (i = 0; environ[i]; i++) {
369 if ((eq = strchr(environ[i],'=')) &&
370 lnmdsc.dsc$w_length == (eq - environ[i]) &&
371 !strncmp(environ[i],uplnm,eq - environ[i])) {
373 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
374 if (!eqvlen) continue;
379 if (retsts != SS$_NOLOGNAM) break;
382 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
383 !str$case_blind_compare(&tmpdsc,&clisym)) {
384 if (!ivsym && !secure) {
385 unsigned short int deflen = LNM$C_NAMLENGTH;
386 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
387 /* dynamic dsc to accomodate possible long value */
388 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
389 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
391 if (eqvlen > MAX_DCL_SYMBOL) {
392 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
393 eqvlen = MAX_DCL_SYMBOL;
394 /* Special hack--we might be called before the interpreter's */
395 /* fully initialized, in which case either thr or PL_curcop */
396 /* might be bogus. We have to check, since ckWARN needs them */
397 /* both to be valid if running threaded */
398 if (ckWARN(WARN_MISC)) {
399 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
402 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
404 _ckvmssts(lib$sfree1_dd(&eqvdsc));
405 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
406 if (retsts == LIB$_NOSUCHSYM) continue;
411 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
412 midx = my_maxidx(lnm);
413 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
414 lnmlst[1].bufadr = cp2;
416 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
417 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
418 if (retsts == SS$_NOLOGNAM) break;
419 /* PPFs have a prefix */
422 *((int *)uplnm) == *((int *)"SYS$") &&
424 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
425 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
426 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
427 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
428 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
429 memcpy(eqv,eqv+4,eqvlen-4);
435 if ((retsts == SS$_IVLOGNAM) ||
436 (retsts == SS$_NOLOGNAM)) { continue; }
439 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
440 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
441 if (retsts == SS$_NOLOGNAM) continue;
444 eqvlen = strlen(eqv);
448 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
449 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
450 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
451 retsts == SS$_NOLOGNAM) {
452 set_errno(EINVAL); set_vaxc_errno(retsts);
454 else _ckvmssts(retsts);
456 } /* end of vmstrnenv */
459 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
460 /* Define as a function so we can access statics. */
461 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
463 return vmstrnenv(lnm,eqv,idx,fildev,
464 #ifdef SECURE_INTERNAL_GETENV
465 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
474 * Note: Uses Perl temp to store result so char * can be returned to
475 * caller; this pointer will be invalidated at next Perl statement
477 * We define this as a function rather than a macro in terms of my_getenv_len()
478 * so that it'll work when PL_curinterp is undefined (and we therefore can't
481 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
483 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
486 static char *__my_getenv_eqv = NULL;
487 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
488 unsigned long int idx = 0;
489 int trnsuccess, success, secure, saverr, savvmserr;
493 midx = my_maxidx(lnm) + 1;
495 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
496 /* Set up a temporary buffer for the return value; Perl will
497 * clean it up at the next statement transition */
498 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
499 if (!tmpsv) return NULL;
503 /* Assume no interpreter ==> single thread */
504 if (__my_getenv_eqv != NULL) {
505 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
508 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
510 eqv = __my_getenv_eqv;
513 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
514 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
516 getcwd(eqv,LNM$C_NAMLENGTH);
520 /* Get rid of "000000/ in rooted filespecs */
523 zeros = strstr(eqv, "/000000/");
526 mlen = len - (zeros - eqv) - 7;
527 memmove(zeros, &zeros[7], mlen);
535 /* Impose security constraints only if tainting */
537 /* Impose security constraints only if tainting */
538 secure = PL_curinterp ? PL_tainting : will_taint;
539 saverr = errno; savvmserr = vaxc$errno;
546 #ifdef SECURE_INTERNAL_GETENV
547 secure ? PERL__TRNENV_SECURE : 0
553 /* For the getenv interface we combine all the equivalence names
554 * of a search list logical into one value to acquire a maximum
555 * value length of 255*128 (assuming %ENV is using logicals).
557 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
559 /* If the name contains a semicolon-delimited index, parse it
560 * off and make sure we only retrieve the equivalence name for
562 if ((cp2 = strchr(lnm,';')) != NULL) {
564 uplnm[cp2-lnm] = '\0';
565 idx = strtoul(cp2+1,NULL,0);
567 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
570 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
572 /* Discard NOLOGNAM on internal calls since we're often looking
573 * for an optional name, and this "error" often shows up as the
574 * (bogus) exit status for a die() call later on. */
575 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
576 return success ? eqv : Nullch;
579 } /* end of my_getenv() */
583 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
585 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
589 unsigned long idx = 0;
591 static char *__my_getenv_len_eqv = NULL;
592 int secure, saverr, savvmserr;
595 midx = my_maxidx(lnm) + 1;
597 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
598 /* Set up a temporary buffer for the return value; Perl will
599 * clean it up at the next statement transition */
600 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
601 if (!tmpsv) return NULL;
605 /* Assume no interpreter ==> single thread */
606 if (__my_getenv_len_eqv != NULL) {
607 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
610 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
612 buf = __my_getenv_len_eqv;
615 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
616 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
619 getcwd(buf,LNM$C_NAMLENGTH);
622 /* Get rid of "000000/ in rooted filespecs */
624 zeros = strstr(buf, "/000000/");
627 mlen = *len - (zeros - buf) - 7;
628 memmove(zeros, &zeros[7], mlen);
637 /* Impose security constraints only if tainting */
638 secure = PL_curinterp ? PL_tainting : will_taint;
639 saverr = errno; savvmserr = vaxc$errno;
646 #ifdef SECURE_INTERNAL_GETENV
647 secure ? PERL__TRNENV_SECURE : 0
653 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
655 if ((cp2 = strchr(lnm,';')) != NULL) {
658 idx = strtoul(cp2+1,NULL,0);
660 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
663 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
665 /* Get rid of "000000/ in rooted filespecs */
668 zeros = strstr(buf, "/000000/");
671 mlen = *len - (zeros - buf) - 7;
672 memmove(zeros, &zeros[7], mlen);
678 /* Discard NOLOGNAM on internal calls since we're often looking
679 * for an optional name, and this "error" often shows up as the
680 * (bogus) exit status for a die() call later on. */
681 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
682 return *len ? buf : Nullch;
685 } /* end of my_getenv_len() */
688 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
690 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
692 /*{{{ void prime_env_iter() */
695 /* Fill the %ENV associative array with all logical names we can
696 * find, in preparation for iterating over it.
699 static int primed = 0;
700 HV *seenhv = NULL, *envhv;
702 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
703 unsigned short int chan;
704 #ifndef CLI$M_TRUSTED
705 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
707 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
708 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
710 bool have_sym = FALSE, have_lnm = FALSE;
711 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
712 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
713 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
714 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
715 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
716 #if defined(PERL_IMPLICIT_CONTEXT)
719 #if defined(USE_ITHREADS)
720 static perl_mutex primenv_mutex;
721 MUTEX_INIT(&primenv_mutex);
724 #if defined(PERL_IMPLICIT_CONTEXT)
725 /* We jump through these hoops because we can be called at */
726 /* platform-specific initialization time, which is before anything is */
727 /* set up--we can't even do a plain dTHX since that relies on the */
728 /* interpreter structure to be initialized */
730 aTHX = PERL_GET_INTERP;
736 if (primed || !PL_envgv) return;
737 MUTEX_LOCK(&primenv_mutex);
738 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
739 envhv = GvHVn(PL_envgv);
740 /* Perform a dummy fetch as an lval to insure that the hash table is
741 * set up. Otherwise, the hv_store() will turn into a nullop. */
742 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
744 for (i = 0; env_tables[i]; i++) {
745 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
746 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
747 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
749 if (have_sym || have_lnm) {
750 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
751 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
752 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
753 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
756 for (i--; i >= 0; i--) {
757 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
760 for (j = 0; environ[j]; j++) {
761 if (!(start = strchr(environ[j],'='))) {
762 if (ckWARN(WARN_INTERNAL))
763 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
767 sv = newSVpv(start,0);
769 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
774 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
775 !str$case_blind_compare(&tmpdsc,&clisym)) {
776 strcpy(cmd,"Show Symbol/Global *");
777 cmddsc.dsc$w_length = 20;
778 if (env_tables[i]->dsc$w_length == 12 &&
779 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
780 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
781 flags = defflags | CLI$M_NOLOGNAM;
784 strcpy(cmd,"Show Logical *");
785 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
786 strcat(cmd," /Table=");
787 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
788 cmddsc.dsc$w_length = strlen(cmd);
790 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
791 flags = defflags | CLI$M_NOCLISYM;
794 /* Create a new subprocess to execute each command, to exclude the
795 * remote possibility that someone could subvert a mbx or file used
796 * to write multiple commands to a single subprocess.
799 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
800 0,&riseandshine,0,0,&clidsc,&clitabdsc);
801 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
802 defflags &= ~CLI$M_TRUSTED;
803 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
805 if (!buf) Newx(buf,mbxbufsiz + 1,char);
806 if (seenhv) SvREFCNT_dec(seenhv);
809 char *cp1, *cp2, *key;
810 unsigned long int sts, iosb[2], retlen, keylen;
813 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
814 if (sts & 1) sts = iosb[0] & 0xffff;
815 if (sts == SS$_ENDOFFILE) {
817 while (substs == 0) { sys$hiber(); wakect++;}
818 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
823 retlen = iosb[0] >> 16;
824 if (!retlen) continue; /* blank line */
826 if (iosb[1] != subpid) {
828 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
832 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
833 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
835 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
836 if (*cp1 == '(' || /* Logical name table name */
837 *cp1 == '=' /* Next eqv of searchlist */) continue;
838 if (*cp1 == '"') cp1++;
839 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
840 key = cp1; keylen = cp2 - cp1;
841 if (keylen && hv_exists(seenhv,key,keylen)) continue;
842 while (*cp2 && *cp2 != '=') cp2++;
843 while (*cp2 && *cp2 == '=') cp2++;
844 while (*cp2 && *cp2 == ' ') cp2++;
845 if (*cp2 == '"') { /* String translation; may embed "" */
846 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
847 cp2++; cp1--; /* Skip "" surrounding translation */
849 else { /* Numeric translation */
850 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
851 cp1--; /* stop on last non-space char */
853 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
854 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
857 PERL_HASH(hash,key,keylen);
859 if (cp1 == cp2 && *cp2 == '.') {
860 /* A single dot usually means an unprintable character, such as a null
861 * to indicate a zero-length value. Get the actual value to make sure.
863 char lnm[LNM$C_NAMLENGTH+1];
864 char eqv[MAX_DCL_SYMBOL+1];
865 strncpy(lnm, key, keylen);
866 int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
867 sv = newSVpvn(eqv, strlen(eqv));
870 sv = newSVpvn(cp2,cp1 - cp2 + 1);
874 hv_store(envhv,key,keylen,sv,hash);
875 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
877 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
878 /* get the PPFs for this process, not the subprocess */
879 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
880 char eqv[LNM$C_NAMLENGTH+1];
882 for (i = 0; ppfs[i]; i++) {
883 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
884 sv = newSVpv(eqv,trnlen);
886 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
891 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
892 if (buf) Safefree(buf);
893 if (seenhv) SvREFCNT_dec(seenhv);
894 MUTEX_UNLOCK(&primenv_mutex);
897 } /* end of prime_env_iter */
901 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
902 /* Define or delete an element in the same "environment" as
903 * vmstrnenv(). If an element is to be deleted, it's removed from
904 * the first place it's found. If it's to be set, it's set in the
905 * place designated by the first element of the table vector.
906 * Like setenv() returns 0 for success, non-zero on error.
909 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
912 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
913 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
915 unsigned long int retsts, usermode = PSL$C_USER;
916 struct itmlst_3 *ile, *ilist;
917 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
918 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
919 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
920 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
921 $DESCRIPTOR(local,"_LOCAL");
924 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
928 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
929 *cp2 = _toupper(*cp1);
930 if (cp1 - lnm > LNM$C_NAMLENGTH) {
931 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
935 lnmdsc.dsc$w_length = cp1 - lnm;
936 if (!tabvec || !*tabvec) tabvec = env_tables;
938 if (!eqv) { /* we're deleting n element */
939 for (curtab = 0; tabvec[curtab]; curtab++) {
940 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
942 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
943 if ((cp1 = strchr(environ[i],'=')) &&
944 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
945 !strncmp(environ[i],lnm,cp1 - environ[i])) {
947 return setenv(lnm,"",1) ? vaxc$errno : 0;
950 ivenv = 1; retsts = SS$_NOLOGNAM;
952 if (ckWARN(WARN_INTERNAL))
953 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
954 ivenv = 1; retsts = SS$_NOSUCHPGM;
960 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
961 !str$case_blind_compare(&tmpdsc,&clisym)) {
962 unsigned int symtype;
963 if (tabvec[curtab]->dsc$w_length == 12 &&
964 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
965 !str$case_blind_compare(&tmpdsc,&local))
966 symtype = LIB$K_CLI_LOCAL_SYM;
967 else symtype = LIB$K_CLI_GLOBAL_SYM;
968 retsts = lib$delete_symbol(&lnmdsc,&symtype);
969 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
970 if (retsts == LIB$_NOSUCHSYM) continue;
974 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
975 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
976 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
977 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
978 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
982 else { /* we're defining a value */
983 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
985 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
987 if (ckWARN(WARN_INTERNAL))
988 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
989 retsts = SS$_NOSUCHPGM;
993 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
994 eqvdsc.dsc$w_length = strlen(eqv);
995 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
996 !str$case_blind_compare(&tmpdsc,&clisym)) {
997 unsigned int symtype;
998 if (tabvec[0]->dsc$w_length == 12 &&
999 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1000 !str$case_blind_compare(&tmpdsc,&local))
1001 symtype = LIB$K_CLI_LOCAL_SYM;
1002 else symtype = LIB$K_CLI_GLOBAL_SYM;
1003 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1006 if (!*eqv) eqvdsc.dsc$w_length = 1;
1007 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1009 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1010 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1011 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1012 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1013 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1014 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1017 Newx(ilist,nseg+1,struct itmlst_3);
1020 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1023 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1025 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1026 ile->itmcode = LNM$_STRING;
1028 if ((j+1) == nseg) {
1029 ile->buflen = strlen(c);
1030 /* in case we are truncating one that's too long */
1031 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1034 ile->buflen = LNM$C_NAMLENGTH;
1038 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1042 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1047 if (!(retsts & 1)) {
1049 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1050 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1051 set_errno(EVMSERR); break;
1052 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1053 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1054 set_errno(EINVAL); break;
1061 set_vaxc_errno(retsts);
1062 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1065 /* We reset error values on success because Perl does an hv_fetch()
1066 * before each hv_store(), and if the thing we're setting didn't
1067 * previously exist, we've got a leftover error message. (Of course,
1068 * this fails in the face of
1069 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1070 * in that the error reported in $! isn't spurious,
1071 * but it's right more often than not.)
1073 set_errno(0); set_vaxc_errno(retsts);
1077 } /* end of vmssetenv() */
1080 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1081 /* This has to be a function since there's a prototype for it in proto.h */
1083 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1086 int len = strlen(lnm);
1090 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1091 if (!strcmp(uplnm,"DEFAULT")) {
1092 if (eqv && *eqv) Perl_my_chdir(eqv);
1096 #ifndef RTL_USES_UTC
1097 if (len == 6 || len == 2) {
1100 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1102 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1103 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1107 (void) vmssetenv(lnm,eqv,NULL);
1111 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1113 * sets a user-mode logical in the process logical name table
1114 * used for redirection of sys$error
1117 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1119 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1120 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1121 unsigned long int iss, attr = LNM$M_CONFINE;
1122 unsigned char acmode = PSL$C_USER;
1123 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1125 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1126 d_name.dsc$w_length = strlen(name);
1128 lnmlst[0].buflen = strlen(eqv);
1129 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1131 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1132 if (!(iss&1)) lib$signal(iss);
1137 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1138 /* my_crypt - VMS password hashing
1139 * my_crypt() provides an interface compatible with the Unix crypt()
1140 * C library function, and uses sys$hash_password() to perform VMS
1141 * password hashing. The quadword hashed password value is returned
1142 * as a NUL-terminated 8 character string. my_crypt() does not change
1143 * the case of its string arguments; in order to match the behavior
1144 * of LOGINOUT et al., alphabetic characters in both arguments must
1145 * be upcased by the caller.
1147 * - fix me to call ACM services when available
1150 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1152 # ifndef UAI$C_PREFERRED_ALGORITHM
1153 # define UAI$C_PREFERRED_ALGORITHM 127
1155 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1156 unsigned short int salt = 0;
1157 unsigned long int sts;
1159 unsigned short int dsc$w_length;
1160 unsigned char dsc$b_type;
1161 unsigned char dsc$b_class;
1162 const char * dsc$a_pointer;
1163 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1164 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1165 struct itmlst_3 uailst[3] = {
1166 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1167 { sizeof salt, UAI$_SALT, &salt, 0},
1168 { 0, 0, NULL, NULL}};
1169 static char hash[9];
1171 usrdsc.dsc$w_length = strlen(usrname);
1172 usrdsc.dsc$a_pointer = usrname;
1173 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1175 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1179 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1184 set_vaxc_errno(sts);
1185 if (sts != RMS$_RNF) return NULL;
1188 txtdsc.dsc$w_length = strlen(textpasswd);
1189 txtdsc.dsc$a_pointer = textpasswd;
1190 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1191 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1194 return (char *) hash;
1196 } /* end of my_crypt() */
1200 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1201 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1202 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1204 /* fixup barenames that are directories for internal use.
1205 * There have been problems with the consistent handling of UNIX
1206 * style directory names when routines are presented with a name that
1207 * has no directory delimitors at all. So this routine will eventually
1210 static char * fixup_bare_dirnames(const char * name)
1212 if (decc_disable_to_vms_logname_translation) {
1219 * A little hack to get around a bug in some implemenation of remove()
1220 * that do not know how to delete a directory
1222 * Delete any file to which user has control access, regardless of whether
1223 * delete access is explicitly allowed.
1224 * Limitations: User must have write access to parent directory.
1225 * Does not block signals or ASTs; if interrupted in midstream
1226 * may leave file with an altered ACL.
1229 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1231 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1233 char *vmsname, *rspec;
1235 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1236 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1237 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1239 unsigned char myace$b_length;
1240 unsigned char myace$b_type;
1241 unsigned short int myace$w_flags;
1242 unsigned long int myace$l_access;
1243 unsigned long int myace$l_ident;
1244 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1245 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1246 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1248 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1249 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1250 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1251 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1252 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1253 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1255 /* Expand the input spec using RMS, since the CRTL remove() and
1256 * system services won't do this by themselves, so we may miss
1257 * a file "hiding" behind a logical name or search list. */
1258 Newx(vmsname, NAM$C_MAXRSS+1, char);
1259 if (do_tovmsspec(name,vmsname,0) == NULL) {
1264 if (decc_posix_compliant_pathnames) {
1265 /* In POSIX mode, we prefer to remove the UNIX name */
1267 remove_name = (char *)name;
1270 Newx(rspec, NAM$C_MAXRSS+1, char);
1271 if (do_rmsexpand(vmsname, rspec, 1, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1277 remove_name = rspec;
1280 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1282 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1283 Newx(remove_name, NAM$C_MAXRSS+1, char);
1284 mp_do_pathify_dirspec(name, remove_name, 0);
1285 if (!rmdir(remove_name)) {
1287 Safefree(remove_name);
1289 return 0; /* Can we just get rid of it? */
1293 if (!rmdir(remove_name)) {
1295 return 0; /* Can we just get rid of it? */
1301 if (!remove(remove_name)) {
1303 return 0; /* Can we just get rid of it? */
1306 /* If not, can changing protections help? */
1307 if (vaxc$errno != RMS$_PRV) {
1312 /* No, so we get our own UIC to use as a rights identifier,
1313 * and the insert an ACE at the head of the ACL which allows us
1314 * to delete the file.
1316 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1317 fildsc.dsc$w_length = strlen(rspec);
1318 fildsc.dsc$a_pointer = rspec;
1320 newace.myace$l_ident = oldace.myace$l_ident;
1321 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1323 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1324 set_errno(ENOENT); break;
1326 set_errno(ENOTDIR); break;
1328 set_errno(ENODEV); break;
1329 case RMS$_SYN: case SS$_INVFILFOROP:
1330 set_errno(EINVAL); break;
1332 set_errno(EACCES); break;
1336 set_vaxc_errno(aclsts);
1340 /* Grab any existing ACEs with this identifier in case we fail */
1341 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1342 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1343 || fndsts == SS$_NOMOREACE ) {
1344 /* Add the new ACE . . . */
1345 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1348 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1350 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1351 Newx(remove_name, NAM$C_MAXRSS+1, char);
1352 mp_do_pathify_dirspec(name, remove_name, 0);
1353 rmsts = rmdir(remove_name);
1354 Safefree(remove_name);
1357 rmsts = rmdir(remove_name);
1361 rmsts = remove(remove_name);
1363 /* We blew it - dir with files in it, no write priv for
1364 * parent directory, etc. Put things back the way they were. */
1365 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1368 addlst[0].bufadr = &oldace;
1369 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1376 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1377 /* We just deleted it, so of course it's not there. Some versions of
1378 * VMS seem to return success on the unlock operation anyhow (after all
1379 * the unlock is successful), but others don't.
1381 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1382 if (aclsts & 1) aclsts = fndsts;
1383 if (!(aclsts & 1)) {
1385 set_vaxc_errno(aclsts);
1393 } /* end of kill_file() */
1397 /*{{{int do_rmdir(char *name)*/
1399 Perl_do_rmdir(pTHX_ const char *name)
1401 char dirfile[NAM$C_MAXRSS+1];
1405 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1406 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1407 else retval = mp_do_kill_file(dirfile, 1);
1410 } /* end of do_rmdir */
1414 * Delete any file to which user has control access, regardless of whether
1415 * delete access is explicitly allowed.
1416 * Limitations: User must have write access to parent directory.
1417 * Does not block signals or ASTs; if interrupted in midstream
1418 * may leave file with an altered ACL.
1421 /*{{{int kill_file(char *name)*/
1423 Perl_kill_file(pTHX_ const char *name)
1425 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1426 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1427 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1428 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1430 unsigned char myace$b_length;
1431 unsigned char myace$b_type;
1432 unsigned short int myace$w_flags;
1433 unsigned long int myace$l_access;
1434 unsigned long int myace$l_ident;
1435 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1436 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1437 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1439 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1440 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1441 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1442 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1443 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1444 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1446 /* Expand the input spec using RMS, since the CRTL remove() and
1447 * system services won't do this by themselves, so we may miss
1448 * a file "hiding" behind a logical name or search list. */
1449 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1450 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1451 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1452 /* If not, can changing protections help? */
1453 if (vaxc$errno != RMS$_PRV) return -1;
1455 /* No, so we get our own UIC to use as a rights identifier,
1456 * and the insert an ACE at the head of the ACL which allows us
1457 * to delete the file.
1459 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1460 fildsc.dsc$w_length = strlen(rspec);
1461 fildsc.dsc$a_pointer = rspec;
1463 newace.myace$l_ident = oldace.myace$l_ident;
1464 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1466 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1467 set_errno(ENOENT); break;
1469 set_errno(ENOTDIR); break;
1471 set_errno(ENODEV); break;
1472 case RMS$_SYN: case SS$_INVFILFOROP:
1473 set_errno(EINVAL); break;
1475 set_errno(EACCES); break;
1479 set_vaxc_errno(aclsts);
1482 /* Grab any existing ACEs with this identifier in case we fail */
1483 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1484 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1485 || fndsts == SS$_NOMOREACE ) {
1486 /* Add the new ACE . . . */
1487 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1489 if ((rmsts = remove(name))) {
1490 /* We blew it - dir with files in it, no write priv for
1491 * parent directory, etc. Put things back the way they were. */
1492 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1495 addlst[0].bufadr = &oldace;
1496 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1503 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1504 /* We just deleted it, so of course it's not there. Some versions of
1505 * VMS seem to return success on the unlock operation anyhow (after all
1506 * the unlock is successful), but others don't.
1508 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1509 if (aclsts & 1) aclsts = fndsts;
1510 if (!(aclsts & 1)) {
1512 set_vaxc_errno(aclsts);
1518 } /* end of kill_file() */
1522 /*{{{int my_mkdir(char *,Mode_t)*/
1524 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1526 STRLEN dirlen = strlen(dir);
1528 /* zero length string sometimes gives ACCVIO */
1529 if (dirlen == 0) return -1;
1531 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1532 * null file name/type. However, it's commonplace under Unix,
1533 * so we'll allow it for a gain in portability.
1535 if (dir[dirlen-1] == '/') {
1536 char *newdir = savepvn(dir,dirlen-1);
1537 int ret = mkdir(newdir,mode);
1541 else return mkdir(dir,mode);
1542 } /* end of my_mkdir */
1545 /*{{{int my_chdir(char *)*/
1547 Perl_my_chdir(pTHX_ const char *dir)
1549 STRLEN dirlen = strlen(dir);
1551 /* zero length string sometimes gives ACCVIO */
1552 if (dirlen == 0) return -1;
1555 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1556 * This does not work if DECC$EFS_CHARSET is active. Hack it here
1557 * so that existing scripts do not need to be changed.
1560 while ((dirlen > 0) && (*dir1 == ' ')) {
1565 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1567 * null file name/type. However, it's commonplace under Unix,
1568 * so we'll allow it for a gain in portability.
1570 * - Preview- '/' will be valid soon on VMS
1572 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1573 char *newdir = savepvn(dir,dirlen-1);
1574 int ret = chdir(newdir);
1578 else return chdir(dir);
1579 } /* end of my_chdir */
1583 /*{{{FILE *my_tmpfile()*/
1590 if ((fp = tmpfile())) return fp;
1592 Newx(cp,L_tmpnam+24,char);
1593 if (decc_filename_unix_only == 0)
1594 strcpy(cp,"Sys$Scratch:");
1597 tmpnam(cp+strlen(cp));
1598 strcat(cp,".Perltmp");
1599 fp = fopen(cp,"w+","fop=dlt");
1606 #ifndef HOMEGROWN_POSIX_SIGNALS
1608 * The C RTL's sigaction fails to check for invalid signal numbers so we
1609 * help it out a bit. The docs are correct, but the actual routine doesn't
1610 * do what the docs say it will.
1612 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1614 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1615 struct sigaction* oact)
1617 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1618 SETERRNO(EINVAL, SS$_INVARG);
1621 return sigaction(sig, act, oact);
1626 #ifdef KILL_BY_SIGPRC
1627 #include <errnodef.h>
1629 /* We implement our own kill() using the undocumented system service
1630 sys$sigprc for one of two reasons:
1632 1.) If the kill() in an older CRTL uses sys$forcex, causing the
1633 target process to do a sys$exit, which usually can't be handled
1634 gracefully...certainly not by Perl and the %SIG{} mechanism.
1636 2.) If the kill() in the CRTL can't be called from a signal
1637 handler without disappearing into the ether, i.e., the signal
1638 it purportedly sends is never trapped. Still true as of VMS 7.3.
1640 sys$sigprc has the same parameters as sys$forcex, but throws an exception
1641 in the target process rather than calling sys$exit.
1643 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1644 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1645 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1646 with condition codes C$_SIG0+nsig*8, catching the exception on the
1647 target process and resignaling with appropriate arguments.
1649 But we don't have that VMS 7.0+ exception handler, so if you
1650 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1652 Also note that SIGTERM is listed in the docs as being "unimplemented",
1653 yet always seems to be signaled with a VMS condition code of 4 (and
1654 correctly handled for that code). So we hardwire it in.
1656 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1657 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1658 than signalling with an unrecognized (and unhandled by CRTL) code.
1661 #define _MY_SIG_MAX 17
1664 Perl_sig_to_vmscondition(int sig)
1666 static unsigned int sig_code[_MY_SIG_MAX+1] =
1669 SS$_HANGUP, /* 1 SIGHUP */
1670 SS$_CONTROLC, /* 2 SIGINT */
1671 SS$_CONTROLY, /* 3 SIGQUIT */
1672 SS$_RADRMOD, /* 4 SIGILL */
1673 SS$_BREAK, /* 5 SIGTRAP */
1674 SS$_OPCCUS, /* 6 SIGABRT */
1675 SS$_COMPAT, /* 7 SIGEMT */
1677 SS$_FLTOVF, /* 8 SIGFPE VAX */
1679 SS$_HPARITH, /* 8 SIGFPE AXP */
1681 SS$_ABORT, /* 9 SIGKILL */
1682 SS$_ACCVIO, /* 10 SIGBUS */
1683 SS$_ACCVIO, /* 11 SIGSEGV */
1684 SS$_BADPARAM, /* 12 SIGSYS */
1685 SS$_NOMBX, /* 13 SIGPIPE */
1686 SS$_ASTFLT, /* 14 SIGALRM */
1692 #if __VMS_VER >= 60200000
1693 static int initted = 0;
1696 sig_code[16] = C$_SIGUSR1;
1697 sig_code[17] = C$_SIGUSR2;
1701 if (sig < _SIG_MIN) return 0;
1702 if (sig > _MY_SIG_MAX) return 0;
1703 return sig_code[sig];
1707 Perl_my_kill(int pid, int sig)
1712 int sys$sigprc(unsigned int *pidadr,
1713 struct dsc$descriptor_s *prcname,
1716 /* sig 0 means validate the PID */
1717 /*------------------------------*/
1719 const unsigned long int jpicode = JPI$_PID;
1722 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
1723 if ($VMS_STATUS_SUCCESS(status))
1726 case SS$_NOSUCHNODE:
1727 case SS$_UNREACHABLE:
1741 code = Perl_sig_to_vmscondition(sig);
1744 SETERRNO(EINVAL, SS$_BADPARAM);
1748 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
1749 * signals are to be sent to multiple processes.
1750 * pid = 0 - all processes in group except ones that the system exempts
1751 * pid = -1 - all processes except ones that the system exempts
1752 * pid = -n - all processes in group (abs(n)) except ...
1753 * For now, just report as not supported.
1757 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
1761 iss = sys$sigprc((unsigned int *)&pid,0,code);
1762 if (iss&1) return 0;
1766 set_errno(EPERM); break;
1768 case SS$_NOSUCHNODE:
1769 case SS$_UNREACHABLE:
1770 set_errno(ESRCH); break;
1772 set_errno(ENOMEM); break;
1777 set_vaxc_errno(iss);
1783 /* Routine to convert a VMS status code to a UNIX status code.
1784 ** More tricky than it appears because of conflicting conventions with
1787 ** VMS status codes are a bit mask, with the least significant bit set for
1790 ** Special UNIX status of EVMSERR indicates that no translation is currently
1791 ** available, and programs should check the VMS status code.
1793 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
1797 #ifndef C_FACILITY_NO
1798 #define C_FACILITY_NO 0x350000
1801 #define DCL_IVVERB 0x38090
1804 int Perl_vms_status_to_unix(int vms_status, int child_flag)
1812 /* Assume the best or the worst */
1813 if (vms_status & STS$M_SUCCESS)
1816 unix_status = EVMSERR;
1818 msg_status = vms_status & ~STS$M_CONTROL;
1820 facility = vms_status & STS$M_FAC_NO;
1821 fac_sp = vms_status & STS$M_FAC_SP;
1822 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
1824 if ((facility == 0) || (fac_sp == 0) && (child_flag == 0)) {
1830 unix_status = EFAULT;
1832 case SS$_DEVOFFLINE:
1833 unix_status = EBUSY;
1836 unix_status = ENOTCONN;
1844 case SS$_INVFILFOROP:
1848 unix_status = EINVAL;
1850 case SS$_UNSUPPORTED:
1851 unix_status = ENOTSUP;
1856 unix_status = EACCES;
1858 case SS$_DEVICEFULL:
1859 unix_status = ENOSPC;
1862 unix_status = ENODEV;
1864 case SS$_NOSUCHFILE:
1865 case SS$_NOSUCHOBJECT:
1866 unix_status = ENOENT;
1868 case SS$_ABORT: /* Fatal case */
1869 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
1870 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
1871 unix_status = EINTR;
1874 unix_status = E2BIG;
1877 unix_status = ENOMEM;
1880 unix_status = EPERM;
1882 case SS$_NOSUCHNODE:
1883 case SS$_UNREACHABLE:
1884 unix_status = ESRCH;
1887 unix_status = ECHILD;
1890 if ((facility == 0) && (msg_no < 8)) {
1891 /* These are not real VMS status codes so assume that they are
1892 ** already UNIX status codes
1894 unix_status = msg_no;
1900 /* Translate a POSIX exit code to a UNIX exit code */
1901 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
1902 unix_status = (msg_no & 0x07F8) >> 3;
1906 /* Documented traditional behavior for handling VMS child exits */
1907 /*--------------------------------------------------------------*/
1908 if (child_flag != 0) {
1910 /* Success / Informational return 0 */
1911 /*----------------------------------*/
1912 if (msg_no & STS$K_SUCCESS)
1915 /* Warning returns 1 */
1916 /*-------------------*/
1917 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
1920 /* Everything else pass through the severity bits */
1921 /*------------------------------------------------*/
1922 return (msg_no & STS$M_SEVERITY);
1925 /* Normal VMS status to ERRNO mapping attempt */
1926 /*--------------------------------------------*/
1927 switch(msg_status) {
1928 /* case RMS$_EOF: */ /* End of File */
1929 case RMS$_FNF: /* File Not Found */
1930 case RMS$_DNF: /* Dir Not Found */
1931 unix_status = ENOENT;
1933 case RMS$_RNF: /* Record Not Found */
1934 unix_status = ESRCH;
1937 unix_status = ENOTDIR;
1940 unix_status = ENODEV;
1945 unix_status = EBADF;
1948 unix_status = EEXIST;
1952 case LIB$_INVSTRDES:
1954 case LIB$_NOSUCHSYM:
1955 case LIB$_INVSYMNAM:
1957 unix_status = EINVAL;
1963 unix_status = E2BIG;
1965 case RMS$_PRV: /* No privilege */
1966 case RMS$_ACC: /* ACP file access failed */
1967 case RMS$_WLK: /* Device write locked */
1968 unix_status = EACCES;
1970 /* case RMS$_NMF: */ /* No more files */
1978 /* Try to guess at what VMS error status should go with a UNIX errno
1979 * value. This is hard to do as there could be many possible VMS
1980 * error statuses that caused the errno value to be set.
1983 int Perl_unix_status_to_vms(int unix_status)
1985 int test_unix_status;
1987 /* Trivial cases first */
1988 /*---------------------*/
1989 if (unix_status == EVMSERR)
1992 /* Is vaxc$errno sane? */
1993 /*---------------------*/
1994 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
1995 if (test_unix_status == unix_status)
1998 /* If way out of range, must be VMS code already */
1999 /*-----------------------------------------------*/
2000 if (unix_status > EVMSERR)
2003 /* If out of range, punt */
2004 /*-----------------------*/
2005 if (unix_status > __ERRNO_MAX)
2009 /* Ok, now we have to do it the hard way. */
2010 /*----------------------------------------*/
2011 switch(unix_status) {
2012 case 0: return SS$_NORMAL;
2013 case EPERM: return SS$_NOPRIV;
2014 case ENOENT: return SS$_NOSUCHOBJECT;
2015 case ESRCH: return SS$_UNREACHABLE;
2016 case EINTR: return SS$_ABORT;
2019 case E2BIG: return SS$_BUFFEROVF;
2021 case EBADF: return RMS$_IFI;
2022 case ECHILD: return SS$_NONEXPR;
2024 case ENOMEM: return SS$_INSFMEM;
2025 case EACCES: return SS$_FILACCERR;
2026 case EFAULT: return SS$_ACCVIO;
2028 case EBUSY: SS$_DEVOFFLINE;
2029 case EEXIST: return RMS$_FEX;
2031 case ENODEV: return SS$_NOSUCHDEV;
2032 case ENOTDIR: return RMS$_DIR;
2034 case EINVAL: return SS$_INVARG;
2040 case ENOSPC: return SS$_DEVICEFULL;
2041 case ESPIPE: return LIB$_INVARG;
2046 case ERANGE: return LIB$_INVARG;
2047 /* case EWOULDBLOCK */
2048 /* case EINPROGRESS */
2051 /* case EDESTADDRREQ */
2053 /* case EPROTOTYPE */
2054 /* case ENOPROTOOPT */
2055 /* case EPROTONOSUPPORT */
2056 /* case ESOCKTNOSUPPORT */
2057 /* case EOPNOTSUPP */
2058 /* case EPFNOSUPPORT */
2059 /* case EAFNOSUPPORT */
2060 /* case EADDRINUSE */
2061 /* case EADDRNOTAVAIL */
2063 /* case ENETUNREACH */
2064 /* case ENETRESET */
2065 /* case ECONNABORTED */
2066 /* case ECONNRESET */
2069 case ENOTCONN: return SS$_CLEARED;
2070 /* case ESHUTDOWN */
2071 /* case ETOOMANYREFS */
2072 /* case ETIMEDOUT */
2073 /* case ECONNREFUSED */
2075 /* case ENAMETOOLONG */
2076 /* case EHOSTDOWN */
2077 /* case EHOSTUNREACH */
2078 /* case ENOTEMPTY */
2090 /* case ECANCELED */
2094 return SS$_UNSUPPORTED;
2100 /* case EABANDONED */
2102 return SS$_ABORT; /* punt */
2105 return SS$_ABORT; /* Should not get here */
2109 /* default piping mailbox size */
2110 #define PERL_BUFSIZ 512
2114 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2116 unsigned long int mbxbufsiz;
2117 static unsigned long int syssize = 0;
2118 unsigned long int dviitm = DVI$_DEVNAM;
2119 char csize[LNM$C_NAMLENGTH+1];
2123 unsigned long syiitm = SYI$_MAXBUF;
2125 * Get the SYSGEN parameter MAXBUF
2127 * If the logical 'PERL_MBX_SIZE' is defined
2128 * use the value of the logical instead of PERL_BUFSIZ, but
2129 * keep the size between 128 and MAXBUF.
2132 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2135 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2136 mbxbufsiz = atoi(csize);
2138 mbxbufsiz = PERL_BUFSIZ;
2140 if (mbxbufsiz < 128) mbxbufsiz = 128;
2141 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2143 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2145 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2146 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2148 } /* end of create_mbx() */
2151 /*{{{ my_popen and my_pclose*/
2153 typedef struct _iosb IOSB;
2154 typedef struct _iosb* pIOSB;
2155 typedef struct _pipe Pipe;
2156 typedef struct _pipe* pPipe;
2157 typedef struct pipe_details Info;
2158 typedef struct pipe_details* pInfo;
2159 typedef struct _srqp RQE;
2160 typedef struct _srqp* pRQE;
2161 typedef struct _tochildbuf CBuf;
2162 typedef struct _tochildbuf* pCBuf;
2165 unsigned short status;
2166 unsigned short count;
2167 unsigned long dvispec;
2170 #pragma member_alignment save
2171 #pragma nomember_alignment quadword
2172 struct _srqp { /* VMS self-relative queue entry */
2173 unsigned long qptr[2];
2175 #pragma member_alignment restore
2176 static RQE RQE_ZERO = {0,0};
2178 struct _tochildbuf {
2181 unsigned short size;
2189 unsigned short chan_in;
2190 unsigned short chan_out;
2192 unsigned int bufsize;
2204 #if defined(PERL_IMPLICIT_CONTEXT)
2205 void *thx; /* Either a thread or an interpreter */
2206 /* pointer, depending on how we're built */
2214 PerlIO *fp; /* file pointer to pipe mailbox */
2215 int useFILE; /* using stdio, not perlio */
2216 int pid; /* PID of subprocess */
2217 int mode; /* == 'r' if pipe open for reading */
2218 int done; /* subprocess has completed */
2219 int waiting; /* waiting for completion/closure */
2220 int closing; /* my_pclose is closing this pipe */
2221 unsigned long completion; /* termination status of subprocess */
2222 pPipe in; /* pipe in to sub */
2223 pPipe out; /* pipe out of sub */
2224 pPipe err; /* pipe of sub's sys$error */
2225 int in_done; /* true when in pipe finished */
2230 struct exit_control_block
2232 struct exit_control_block *flink;
2233 unsigned long int (*exit_routine)();
2234 unsigned long int arg_count;
2235 unsigned long int *status_address;
2236 unsigned long int exit_status;
2239 typedef struct _closed_pipes Xpipe;
2240 typedef struct _closed_pipes* pXpipe;
2242 struct _closed_pipes {
2243 int pid; /* PID of subprocess */
2244 unsigned long completion; /* termination status of subprocess */
2246 #define NKEEPCLOSED 50
2247 static Xpipe closed_list[NKEEPCLOSED];
2248 static int closed_index = 0;
2249 static int closed_num = 0;
2251 #define RETRY_DELAY "0 ::0.20"
2252 #define MAX_RETRY 50
2254 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2255 static unsigned long mypid;
2256 static unsigned long delaytime[2];
2258 static pInfo open_pipes = NULL;
2259 static $DESCRIPTOR(nl_desc, "NL:");
2261 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2265 static unsigned long int
2266 pipe_exit_routine(pTHX)
2269 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2270 int sts, did_stuff, need_eof, j;
2273 flush any pending i/o
2279 PerlIO_flush(info->fp); /* first, flush data */
2281 fflush((FILE *)info->fp);
2287 next we try sending an EOF...ignore if doesn't work, make sure we
2295 _ckvmssts(sys$setast(0));
2296 if (info->in && !info->in->shut_on_empty) {
2297 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2302 _ckvmssts(sys$setast(1));
2306 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2308 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2313 _ckvmssts(sys$setast(0));
2314 if (info->waiting && info->done)
2316 nwait += info->waiting;
2317 _ckvmssts(sys$setast(1));
2327 _ckvmssts(sys$setast(0));
2328 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2329 sts = sys$forcex(&info->pid,0,&abort);
2330 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
2333 _ckvmssts(sys$setast(1));
2337 /* again, wait for effect */
2339 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2344 _ckvmssts(sys$setast(0));
2345 if (info->waiting && info->done)
2347 nwait += info->waiting;
2348 _ckvmssts(sys$setast(1));
2357 _ckvmssts(sys$setast(0));
2358 if (!info->done) { /* We tried to be nice . . . */
2359 sts = sys$delprc(&info->pid,0);
2360 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
2362 _ckvmssts(sys$setast(1));
2367 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2368 else if (!(sts & 1)) retsts = sts;
2373 static struct exit_control_block pipe_exitblock =
2374 {(struct exit_control_block *) 0,
2375 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2377 static void pipe_mbxtofd_ast(pPipe p);
2378 static void pipe_tochild1_ast(pPipe p);
2379 static void pipe_tochild2_ast(pPipe p);
2382 popen_completion_ast(pInfo info)
2384 pInfo i = open_pipes;
2389 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2390 closed_list[closed_index].pid = info->pid;
2391 closed_list[closed_index].completion = info->completion;
2393 if (closed_index == NKEEPCLOSED)
2398 if (i == info) break;
2401 if (!i) return; /* unlinked, probably freed too */
2406 Writing to subprocess ...
2407 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2409 chan_out may be waiting for "done" flag, or hung waiting
2410 for i/o completion to child...cancel the i/o. This will
2411 put it into "snarf mode" (done but no EOF yet) that discards
2414 Output from subprocess (stdout, stderr) needs to be flushed and
2415 shut down. We try sending an EOF, but if the mbx is full the pipe
2416 routine should still catch the "shut_on_empty" flag, telling it to
2417 use immediate-style reads so that "mbx empty" -> EOF.
2421 if (info->in && !info->in_done) { /* only for mode=w */
2422 if (info->in->shut_on_empty && info->in->need_wake) {
2423 info->in->need_wake = FALSE;
2424 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2426 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2430 if (info->out && !info->out_done) { /* were we also piping output? */
2431 info->out->shut_on_empty = TRUE;
2432 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2433 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2434 _ckvmssts_noperl(iss);
2437 if (info->err && !info->err_done) { /* we were piping stderr */
2438 info->err->shut_on_empty = TRUE;
2439 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2440 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2441 _ckvmssts_noperl(iss);
2443 _ckvmssts_noperl(sys$setef(pipe_ef));
2447 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2448 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2451 we actually differ from vmstrnenv since we use this to
2452 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2453 are pointing to the same thing
2456 static unsigned short
2457 popen_translate(pTHX_ char *logical, char *result)
2460 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2461 $DESCRIPTOR(d_log,"");
2463 unsigned short length;
2464 unsigned short code;
2466 unsigned short *retlenaddr;
2468 unsigned short l, ifi;
2470 d_log.dsc$a_pointer = logical;
2471 d_log.dsc$w_length = strlen(logical);
2473 itmlst[0].code = LNM$_STRING;
2474 itmlst[0].length = 255;
2475 itmlst[0].buffer_addr = result;
2476 itmlst[0].retlenaddr = &l;
2479 itmlst[1].length = 0;
2480 itmlst[1].buffer_addr = 0;
2481 itmlst[1].retlenaddr = 0;
2483 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2484 if (iss == SS$_NOLOGNAM) {
2488 if (!(iss&1)) lib$signal(iss);
2491 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
2492 strip it off and return the ifi, if any
2495 if (result[0] == 0x1b && result[1] == 0x00) {
2496 memcpy(&ifi,result+2,2);
2497 strcpy(result,result+4);
2499 return ifi; /* this is the RMS internal file id */
2502 static void pipe_infromchild_ast(pPipe p);
2505 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2506 inside an AST routine without worrying about reentrancy and which Perl
2507 memory allocator is being used.
2509 We read data and queue up the buffers, then spit them out one at a
2510 time to the output mailbox when the output mailbox is ready for one.
2513 #define INITIAL_TOCHILDQUEUE 2
2516 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2520 char mbx1[64], mbx2[64];
2521 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2522 DSC$K_CLASS_S, mbx1},
2523 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2524 DSC$K_CLASS_S, mbx2};
2525 unsigned int dviitm = DVI$_DEVBUFSIZ;
2530 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2531 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2532 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2535 p->shut_on_empty = FALSE;
2536 p->need_wake = FALSE;
2539 p->iosb.status = SS$_NORMAL;
2540 p->iosb2.status = SS$_NORMAL;
2546 #ifdef PERL_IMPLICIT_CONTEXT
2550 n = sizeof(CBuf) + p->bufsize;
2552 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2553 _ckvmssts(lib$get_vm(&n, &b));
2554 b->buf = (char *) b + sizeof(CBuf);
2555 _ckvmssts(lib$insqhi(b, &p->free));
2558 pipe_tochild2_ast(p);
2559 pipe_tochild1_ast(p);
2565 /* reads the MBX Perl is writing, and queues */
2568 pipe_tochild1_ast(pPipe p)
2571 int iss = p->iosb.status;
2572 int eof = (iss == SS$_ENDOFFILE);
2574 #ifdef PERL_IMPLICIT_CONTEXT
2580 p->shut_on_empty = TRUE;
2582 _ckvmssts(sys$dassgn(p->chan_in));
2588 b->size = p->iosb.count;
2589 _ckvmssts(sts = lib$insqhi(b, &p->wait));
2591 p->need_wake = FALSE;
2592 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2595 p->retry = 1; /* initial call */
2598 if (eof) { /* flush the free queue, return when done */
2599 int n = sizeof(CBuf) + p->bufsize;
2601 iss = lib$remqti(&p->free, &b);
2602 if (iss == LIB$_QUEWASEMP) return;
2604 _ckvmssts(lib$free_vm(&n, &b));
2608 iss = lib$remqti(&p->free, &b);
2609 if (iss == LIB$_QUEWASEMP) {
2610 int n = sizeof(CBuf) + p->bufsize;
2611 _ckvmssts(lib$get_vm(&n, &b));
2612 b->buf = (char *) b + sizeof(CBuf);
2618 iss = sys$qio(0,p->chan_in,
2619 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2621 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2622 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2627 /* writes queued buffers to output, waits for each to complete before
2631 pipe_tochild2_ast(pPipe p)
2634 int iss = p->iosb2.status;
2635 int n = sizeof(CBuf) + p->bufsize;
2636 int done = (p->info && p->info->done) ||
2637 iss == SS$_CANCEL || iss == SS$_ABORT;
2638 #if defined(PERL_IMPLICIT_CONTEXT)
2643 if (p->type) { /* type=1 has old buffer, dispose */
2644 if (p->shut_on_empty) {
2645 _ckvmssts(lib$free_vm(&n, &b));
2647 _ckvmssts(lib$insqhi(b, &p->free));
2652 iss = lib$remqti(&p->wait, &b);
2653 if (iss == LIB$_QUEWASEMP) {
2654 if (p->shut_on_empty) {
2656 _ckvmssts(sys$dassgn(p->chan_out));
2657 *p->pipe_done = TRUE;
2658 _ckvmssts(sys$setef(pipe_ef));
2660 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2661 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2665 p->need_wake = TRUE;
2675 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2676 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2678 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2679 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2688 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2691 char mbx1[64], mbx2[64];
2692 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2693 DSC$K_CLASS_S, mbx1},
2694 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2695 DSC$K_CLASS_S, mbx2};
2696 unsigned int dviitm = DVI$_DEVBUFSIZ;
2699 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2700 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2702 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2703 Newx(p->buf, p->bufsize, char);
2704 p->shut_on_empty = FALSE;
2707 p->iosb.status = SS$_NORMAL;
2708 #if defined(PERL_IMPLICIT_CONTEXT)
2711 pipe_infromchild_ast(p);
2719 pipe_infromchild_ast(pPipe p)
2721 int iss = p->iosb.status;
2722 int eof = (iss == SS$_ENDOFFILE);
2723 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2724 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2725 #if defined(PERL_IMPLICIT_CONTEXT)
2729 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
2730 _ckvmssts(sys$dassgn(p->chan_out));
2735 input shutdown if EOF from self (done or shut_on_empty)
2736 output shutdown if closing flag set (my_pclose)
2737 send data/eof from child or eof from self
2738 otherwise, re-read (snarf of data from child)
2743 if (myeof && p->chan_in) { /* input shutdown */
2744 _ckvmssts(sys$dassgn(p->chan_in));
2749 if (myeof || kideof) { /* pass EOF to parent */
2750 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2751 pipe_infromchild_ast, p,
2754 } else if (eof) { /* eat EOF --- fall through to read*/
2756 } else { /* transmit data */
2757 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2758 pipe_infromchild_ast,p,
2759 p->buf, p->iosb.count, 0, 0, 0, 0));
2765 /* everything shut? flag as done */
2767 if (!p->chan_in && !p->chan_out) {
2768 *p->pipe_done = TRUE;
2769 _ckvmssts(sys$setef(pipe_ef));
2773 /* write completed (or read, if snarfing from child)
2774 if still have input active,
2775 queue read...immediate mode if shut_on_empty so we get EOF if empty
2777 check if Perl reading, generate EOFs as needed
2783 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2784 pipe_infromchild_ast,p,
2785 p->buf, p->bufsize, 0, 0, 0, 0);
2786 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2788 } else { /* send EOFs for extra reads */
2789 p->iosb.status = SS$_ENDOFFILE;
2790 p->iosb.dvispec = 0;
2791 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2793 pipe_infromchild_ast, p, 0, 0, 0, 0));
2799 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2803 unsigned long dviitm = DVI$_DEVBUFSIZ;
2805 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2806 DSC$K_CLASS_S, mbx};
2808 /* things like terminals and mbx's don't need this filter */
2809 if (fd && fstat(fd,&s) == 0) {
2810 unsigned long dviitm = DVI$_DEVCHAR, devchar;
2811 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2812 DSC$K_CLASS_S, s.st_dev};
2814 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2815 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
2816 strcpy(out, s.st_dev);
2822 p->fd_out = dup(fd);
2823 create_mbx(aTHX_ &p->chan_in, &d_mbx);
2824 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2825 Newx(p->buf, p->bufsize+1, char);
2826 p->shut_on_empty = FALSE;
2831 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2832 pipe_mbxtofd_ast, p,
2833 p->buf, p->bufsize, 0, 0, 0, 0));
2839 pipe_mbxtofd_ast(pPipe p)
2841 int iss = p->iosb.status;
2842 int done = p->info->done;
2844 int eof = (iss == SS$_ENDOFFILE);
2845 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2846 int err = !(iss&1) && !eof;
2847 #if defined(PERL_IMPLICIT_CONTEXT)
2851 if (done && myeof) { /* end piping */
2853 sys$dassgn(p->chan_in);
2854 *p->pipe_done = TRUE;
2855 _ckvmssts(sys$setef(pipe_ef));
2859 if (!err && !eof) { /* good data to send to file */
2860 p->buf[p->iosb.count] = '\n';
2861 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2864 if (p->retry < MAX_RETRY) {
2865 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2875 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2876 pipe_mbxtofd_ast, p,
2877 p->buf, p->bufsize, 0, 0, 0, 0);
2878 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2883 typedef struct _pipeloc PLOC;
2884 typedef struct _pipeloc* pPLOC;
2888 char dir[NAM$C_MAXRSS+1];
2890 static pPLOC head_PLOC = 0;
2893 free_pipelocs(pTHX_ void *head)
2896 pPLOC *pHead = (pPLOC *)head;
2908 store_pipelocs(pTHX)
2917 char temp[NAM$C_MAXRSS+1];
2921 free_pipelocs(aTHX_ &head_PLOC);
2923 /* the . directory from @INC comes last */
2926 p->next = head_PLOC;
2928 strcpy(p->dir,"./");
2930 /* get the directory from $^X */
2932 #ifdef PERL_IMPLICIT_CONTEXT
2933 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2935 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2937 strcpy(temp, PL_origargv[0]);
2938 x = strrchr(temp,']');
2940 x = strrchr(temp,'>');
2942 /* It could be a UNIX path */
2943 x = strrchr(temp,'/');
2949 /* Got a bare name, so use default directory */
2954 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2956 p->next = head_PLOC;
2958 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2959 p->dir[NAM$C_MAXRSS] = '\0';
2963 /* reverse order of @INC entries, skip "." since entered above */
2965 #ifdef PERL_IMPLICIT_CONTEXT
2968 if (PL_incgv) av = GvAVn(PL_incgv);
2970 for (i = 0; av && i <= AvFILL(av); i++) {
2971 dirsv = *av_fetch(av,i,TRUE);
2973 if (SvROK(dirsv)) continue;
2974 dir = SvPVx(dirsv,n_a);
2975 if (strcmp(dir,".") == 0) continue;
2976 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2980 p->next = head_PLOC;
2982 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2983 p->dir[NAM$C_MAXRSS] = '\0';
2986 /* most likely spot (ARCHLIB) put first in the list */
2989 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2991 p->next = head_PLOC;
2993 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2994 p->dir[NAM$C_MAXRSS] = '\0';
3003 static int vmspipe_file_status = 0;
3004 static char vmspipe_file[NAM$C_MAXRSS+1];
3006 /* already found? Check and use ... need read+execute permission */
3008 if (vmspipe_file_status == 1) {
3009 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3010 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3011 return vmspipe_file;
3013 vmspipe_file_status = 0;
3016 /* scan through stored @INC, $^X */
3018 if (vmspipe_file_status == 0) {
3019 char file[NAM$C_MAXRSS+1];
3020 pPLOC p = head_PLOC;
3023 strcpy(file, p->dir);
3024 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3025 file[NAM$C_MAXRSS] = '\0';
3028 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3030 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3031 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3032 vmspipe_file_status = 1;
3033 return vmspipe_file;
3036 vmspipe_file_status = -1; /* failed, use tempfiles */
3043 vmspipe_tempfile(pTHX)
3045 char file[NAM$C_MAXRSS+1];
3047 static int index = 0;
3051 /* create a tempfile */
3053 /* we can't go from W, shr=get to R, shr=get without
3054 an intermediate vulnerable state, so don't bother trying...
3056 and lib$spawn doesn't shr=put, so have to close the write
3058 So... match up the creation date/time and the FID to
3059 make sure we're dealing with the same file
3064 if (!decc_filename_unix_only) {
3065 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3066 fp = fopen(file,"w");
3068 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3069 fp = fopen(file,"w");
3071 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3072 fp = fopen(file,"w");
3077 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3078 fp = fopen(file,"w");
3080 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3081 fp = fopen(file,"w");
3083 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3084 fp = fopen(file,"w");
3088 if (!fp) return 0; /* we're hosed */
3090 fprintf(fp,"$! 'f$verify(0)'\n");
3091 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3092 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3093 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3094 fprintf(fp,"$ perl_on = \"set noon\"\n");
3095 fprintf(fp,"$ perl_exit = \"exit\"\n");
3096 fprintf(fp,"$ perl_del = \"delete\"\n");
3097 fprintf(fp,"$ pif = \"if\"\n");
3098 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3099 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3100 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3101 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3102 fprintf(fp,"$! --- build command line to get max possible length\n");
3103 fprintf(fp,"$c=perl_popen_cmd0\n");
3104 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3105 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3106 fprintf(fp,"$x=perl_popen_cmd3\n");
3107 fprintf(fp,"$c=c+x\n");
3108 fprintf(fp,"$ perl_on\n");
3109 fprintf(fp,"$ 'c'\n");
3110 fprintf(fp,"$ perl_status = $STATUS\n");
3111 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3112 fprintf(fp,"$ perl_exit 'perl_status'\n");
3115 fgetname(fp, file, 1);
3116 fstat(fileno(fp), (struct stat *)&s0);
3119 if (decc_filename_unix_only)
3120 do_tounixspec(file, file, 0);
3121 fp = fopen(file,"r","shr=get");
3123 fstat(fileno(fp), (struct stat *)&s1);
3125 #if defined(_USE_STD_STAT)
3126 cmp_result = s0.st_ino != s1.st_ino;
3128 cmp_result = memcmp(&s0.st_ino, &s1.st_ino, 6);
3130 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3141 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3143 static int handler_set_up = FALSE;
3144 unsigned long int sts, flags = CLI$M_NOWAIT;
3145 /* The use of a GLOBAL table (as was done previously) rendered
3146 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3147 * environment. Hence we've switched to LOCAL symbol table.
3149 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3151 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3152 char in[512], out[512], err[512], mbx[512];
3154 char tfilebuf[NAM$C_MAXRSS+1];
3156 char cmd_sym_name[20];
3157 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3158 DSC$K_CLASS_S, symbol};
3159 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3161 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3162 DSC$K_CLASS_S, cmd_sym_name};
3163 struct dsc$descriptor_s *vmscmd;
3164 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3165 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3166 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3168 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3170 /* once-per-program initialization...
3171 note that the SETAST calls and the dual test of pipe_ef
3172 makes sure that only the FIRST thread through here does
3173 the initialization...all other threads wait until it's
3176 Yeah, uglier than a pthread call, it's got all the stuff inline
3177 rather than in a separate routine.
3181 _ckvmssts(sys$setast(0));
3183 unsigned long int pidcode = JPI$_PID;
3184 $DESCRIPTOR(d_delay, RETRY_DELAY);
3185 _ckvmssts(lib$get_ef(&pipe_ef));
3186 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3187 _ckvmssts(sys$bintim(&d_delay, delaytime));
3189 if (!handler_set_up) {
3190 _ckvmssts(sys$dclexh(&pipe_exitblock));
3191 handler_set_up = TRUE;
3193 _ckvmssts(sys$setast(1));
3196 /* see if we can find a VMSPIPE.COM */
3199 vmspipe = find_vmspipe(aTHX);
3201 strcpy(tfilebuf+1,vmspipe);
3202 } else { /* uh, oh...we're in tempfile hell */
3203 tpipe = vmspipe_tempfile(aTHX);
3204 if (!tpipe) { /* a fish popular in Boston */
3205 if (ckWARN(WARN_PIPE)) {
3206 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3210 fgetname(tpipe,tfilebuf+1,1);
3212 vmspipedsc.dsc$a_pointer = tfilebuf;
3213 vmspipedsc.dsc$w_length = strlen(tfilebuf);
3215 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3218 case RMS$_FNF: case RMS$_DNF:
3219 set_errno(ENOENT); break;
3221 set_errno(ENOTDIR); break;
3223 set_errno(ENODEV); break;
3225 set_errno(EACCES); break;
3227 set_errno(EINVAL); break;
3228 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3229 set_errno(E2BIG); break;
3230 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3231 _ckvmssts(sts); /* fall through */
3232 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3235 set_vaxc_errno(sts);
3236 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3237 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3244 strcpy(mode,in_mode);
3247 info->completion = 0;
3248 info->closing = FALSE;
3255 info->in_done = TRUE;
3256 info->out_done = TRUE;
3257 info->err_done = TRUE;
3258 in[0] = out[0] = err[0] = '\0';
3260 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
3264 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
3269 if (*mode == 'r') { /* piping from subroutine */
3271 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3273 info->out->pipe_done = &info->out_done;
3274 info->out_done = FALSE;
3275 info->out->info = info;
3277 if (!info->useFILE) {
3278 info->fp = PerlIO_open(mbx, mode);
3280 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3281 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3284 if (!info->fp && info->out) {
3285 sys$cancel(info->out->chan_out);
3287 while (!info->out_done) {
3289 _ckvmssts(sys$setast(0));
3290 done = info->out_done;
3291 if (!done) _ckvmssts(sys$clref(pipe_ef));
3292 _ckvmssts(sys$setast(1));
3293 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3296 if (info->out->buf) Safefree(info->out->buf);
3297 Safefree(info->out);
3303 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3305 info->err->pipe_done = &info->err_done;
3306 info->err_done = FALSE;
3307 info->err->info = info;
3310 } else if (*mode == 'w') { /* piping to subroutine */
3312 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3314 info->out->pipe_done = &info->out_done;
3315 info->out_done = FALSE;
3316 info->out->info = info;
3319 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3321 info->err->pipe_done = &info->err_done;
3322 info->err_done = FALSE;
3323 info->err->info = info;
3326 info->in = pipe_tochild_setup(aTHX_ in,mbx);
3327 if (!info->useFILE) {
3328 info->fp = PerlIO_open(mbx, mode);
3330 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3331 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3335 info->in->pipe_done = &info->in_done;
3336 info->in_done = FALSE;
3337 info->in->info = info;
3341 if (!info->fp && info->in) {
3343 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3344 0, 0, 0, 0, 0, 0, 0, 0));
3346 while (!info->in_done) {
3348 _ckvmssts(sys$setast(0));
3349 done = info->in_done;
3350 if (!done) _ckvmssts(sys$clref(pipe_ef));
3351 _ckvmssts(sys$setast(1));
3352 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3355 if (info->in->buf) Safefree(info->in->buf);
3363 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
3364 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3366 info->out->pipe_done = &info->out_done;
3367 info->out_done = FALSE;
3368 info->out->info = info;
3371 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3373 info->err->pipe_done = &info->err_done;
3374 info->err_done = FALSE;
3375 info->err->info = info;
3379 symbol[MAX_DCL_SYMBOL] = '\0';
3381 strncpy(symbol, in, MAX_DCL_SYMBOL);
3382 d_symbol.dsc$w_length = strlen(symbol);
3383 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3385 strncpy(symbol, err, MAX_DCL_SYMBOL);
3386 d_symbol.dsc$w_length = strlen(symbol);
3387 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3389 strncpy(symbol, out, MAX_DCL_SYMBOL);
3390 d_symbol.dsc$w_length = strlen(symbol);
3391 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3393 p = vmscmd->dsc$a_pointer;
3394 while (*p && *p != '\n') p++;
3395 *p = '\0'; /* truncate on \n */
3396 p = vmscmd->dsc$a_pointer;
3397 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
3398 if (*p == '$') p++; /* remove leading $ */
3399 while (*p == ' ' || *p == '\t') p++;
3401 for (j = 0; j < 4; j++) {
3402 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3403 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3405 strncpy(symbol, p, MAX_DCL_SYMBOL);
3406 d_symbol.dsc$w_length = strlen(symbol);
3407 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3409 if (strlen(p) > MAX_DCL_SYMBOL) {
3410 p += MAX_DCL_SYMBOL;
3415 _ckvmssts(sys$setast(0));
3416 info->next=open_pipes; /* prepend to list */
3418 _ckvmssts(sys$setast(1));
3419 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3420 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
3421 * have SYS$COMMAND if we need it.
3423 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3424 0, &info->pid, &info->completion,
3425 0, popen_completion_ast,info,0,0,0));
3427 /* if we were using a tempfile, close it now */
3429 if (tpipe) fclose(tpipe);
3431 /* once the subprocess is spawned, it has copied the symbols and
3432 we can get rid of ours */
3434 for (j = 0; j < 4; j++) {
3435 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3436 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3437 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3439 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
3440 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3441 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3442 vms_execfree(vmscmd);
3444 #ifdef PERL_IMPLICIT_CONTEXT
3447 PL_forkprocess = info->pid;
3452 _ckvmssts(sys$setast(0));
3454 if (!done) _ckvmssts(sys$clref(pipe_ef));
3455 _ckvmssts(sys$setast(1));
3456 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3458 *psts = info->completion;
3459 /* Caller thinks it is open and tries to close it. */
3460 /* This causes some problems, as it changes the error status */
3461 /* my_pclose(info->fp); */
3466 } /* end of safe_popen */
3469 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
3471 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3475 TAINT_PROPER("popen");
3476 PERL_FLUSHALL_FOR_CHILD;
3477 return safe_popen(aTHX_ cmd,mode,&sts);
3482 /*{{{ I32 my_pclose(PerlIO *fp)*/
3483 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3485 pInfo info, last = NULL;
3486 unsigned long int retsts;
3489 for (info = open_pipes; info != NULL; last = info, info = info->next)
3490 if (info->fp == fp) break;
3492 if (info == NULL) { /* no such pipe open */
3493 set_errno(ECHILD); /* quoth POSIX */
3494 set_vaxc_errno(SS$_NONEXPR);
3498 /* If we were writing to a subprocess, insure that someone reading from
3499 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
3500 * produce an EOF record in the mailbox.
3502 * well, at least sometimes it *does*, so we have to watch out for
3503 * the first EOF closing the pipe (and DASSGN'ing the channel)...
3507 PerlIO_flush(info->fp); /* first, flush data */
3509 fflush((FILE *)info->fp);
3512 _ckvmssts(sys$setast(0));
3513 info->closing = TRUE;
3514 done = info->done && info->in_done && info->out_done && info->err_done;
3515 /* hanging on write to Perl's input? cancel it */
3516 if (info->mode == 'r' && info->out && !info->out_done) {
3517 if (info->out->chan_out) {
3518 _ckvmssts(sys$cancel(info->out->chan_out));
3519 if (!info->out->chan_in) { /* EOF generation, need AST */
3520 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3524 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
3525 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3527 _ckvmssts(sys$setast(1));
3530 PerlIO_close(info->fp);
3532 fclose((FILE *)info->fp);
3535 we have to wait until subprocess completes, but ALSO wait until all
3536 the i/o completes...otherwise we'll be freeing the "info" structure
3537 that the i/o ASTs could still be using...
3541 _ckvmssts(sys$setast(0));
3542 done = info->done && info->in_done && info->out_done && info->err_done;
3543 if (!done) _ckvmssts(sys$clref(pipe_ef));
3544 _ckvmssts(sys$setast(1));
3545 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3547 retsts = info->completion;
3549 /* remove from list of open pipes */
3550 _ckvmssts(sys$setast(0));
3551 if (last) last->next = info->next;
3552 else open_pipes = info->next;
3553 _ckvmssts(sys$setast(1));
3555 /* free buffers and structures */
3558 if (info->in->buf) Safefree(info->in->buf);
3562 if (info->out->buf) Safefree(info->out->buf);
3563 Safefree(info->out);
3566 if (info->err->buf) Safefree(info->err->buf);
3567 Safefree(info->err);
3573 } /* end of my_pclose() */
3575 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3576 /* Roll our own prototype because we want this regardless of whether
3577 * _VMS_WAIT is defined.
3579 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3581 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3582 created with popen(); otherwise partially emulate waitpid() unless
3583 we have a suitable one from the CRTL that came with VMS 7.2 and later.
3584 Also check processes not considered by the CRTL waitpid().
3586 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3588 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3595 if (statusp) *statusp = 0;
3597 for (info = open_pipes; info != NULL; info = info->next)
3598 if (info->pid == pid) break;
3600 if (info != NULL) { /* we know about this child */
3601 while (!info->done) {
3602 _ckvmssts(sys$setast(0));
3604 if (!done) _ckvmssts(sys$clref(pipe_ef));
3605 _ckvmssts(sys$setast(1));
3606 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3609 if (statusp) *statusp = info->completion;
3613 /* child that already terminated? */
3615 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3616 if (closed_list[j].pid == pid) {
3617 if (statusp) *statusp = closed_list[j].completion;
3622 /* fall through if this child is not one of our own pipe children */
3624 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3626 /* waitpid() became available in the CRTL as of VMS 7.0, but only
3627 * in 7.2 did we get a version that fills in the VMS completion
3628 * status as Perl has always tried to do.
3631 sts = __vms_waitpid( pid, statusp, flags );
3633 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3636 /* If the real waitpid tells us the child does not exist, we
3637 * fall through here to implement waiting for a child that
3638 * was created by some means other than exec() (say, spawned
3639 * from DCL) or to wait for a process that is not a subprocess
3640 * of the current process.
3643 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3646 $DESCRIPTOR(intdsc,"0 00:00:01");
3647 unsigned long int ownercode = JPI$_OWNER, ownerpid;
3648 unsigned long int pidcode = JPI$_PID, mypid;
3649 unsigned long int interval[2];
3650 unsigned int jpi_iosb[2];
3651 struct itmlst_3 jpilist[2] = {
3652 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
3657 /* Sorry folks, we don't presently implement rooting around for
3658 the first child we can find, and we definitely don't want to
3659 pass a pid of -1 to $getjpi, where it is a wildcard operation.
3665 /* Get the owner of the child so I can warn if it's not mine. If the
3666 * process doesn't exist or I don't have the privs to look at it,
3667 * I can go home early.
3669 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3670 if (sts & 1) sts = jpi_iosb[0];
3682 set_vaxc_errno(sts);
3686 if (ckWARN(WARN_EXEC)) {
3687 /* remind folks they are asking for non-standard waitpid behavior */
3688 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3689 if (ownerpid != mypid)
3690 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3691 "waitpid: process %x is not a child of process %x",
3695 /* simply check on it once a second until it's not there anymore. */
3697 _ckvmssts(sys$bintim(&intdsc,interval));
3698 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3699 _ckvmssts(sys$schdwk(0,0,interval,0));
3700 _ckvmssts(sys$hiber());
3702 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3707 } /* end of waitpid() */
3712 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3714 my_gconvert(double val, int ndig, int trail, char *buf)
3716 static char __gcvtbuf[DBL_DIG+1];
3719 loc = buf ? buf : __gcvtbuf;
3721 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
3723 sprintf(loc,"%.*g",ndig,val);
3729 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3730 return gcvt(val,ndig,loc);
3733 loc[0] = '0'; loc[1] = '\0';
3741 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3742 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
3743 * to expand file specification. Allows for a single default file
3744 * specification and a simple mask of options. If outbuf is non-NULL,
3745 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3746 * the resultant file specification is placed. If outbuf is NULL, the
3747 * resultant file specification is placed into a static buffer.
3748 * The third argument, if non-NULL, is taken to be a default file
3749 * specification string. The fourth argument is unused at present.
3750 * rmesexpand() returns the address of the resultant string if
3751 * successful, and NULL on error.
3753 * New functionality for previously unused opts value:
3754 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
3756 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
3759 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3761 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
3762 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
3763 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3764 struct FAB myfab = cc$rms_fab;
3765 struct NAM mynam = cc$rms_nam;
3767 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3770 if (!filespec || !*filespec) {
3771 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3775 if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
3776 else outbuf = __rmsexpand_retbuf;
3778 isunix = is_unix_filespec(filespec);
3780 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
3781 filespec = vmsfspec;
3784 myfab.fab$l_fna = (char *)filespec; /* cast ok for read only pointer */
3785 myfab.fab$b_fns = strlen(filespec);
3786 myfab.fab$l_nam = &mynam;
3788 if (defspec && *defspec) {
3789 if (strchr(defspec,'/') != NULL) {
3790 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
3793 myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
3794 myfab.fab$b_dns = strlen(defspec);
3797 mynam.nam$l_esa = esa;
3798 mynam.nam$b_ess = sizeof esa;
3799 mynam.nam$l_rsa = outbuf;
3800 mynam.nam$b_rss = NAM$C_MAXRSS;
3802 retsts = sys$parse(&myfab,0,0);
3803 if (!(retsts & 1)) {
3804 mynam.nam$b_nop |= NAM$M_SYNCHK;
3805 #ifdef NAM$M_NO_SHORT_UPCASE
3806 if (decc_efs_case_preserve)
3807 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3809 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
3810 retsts = sys$parse(&myfab,0,0);
3811 if (retsts & 1) goto expanded;
3813 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3814 sts = sys$parse(&myfab,0,0); /* Free search context */
3815 if (out) Safefree(out);
3816 set_vaxc_errno(retsts);
3817 if (retsts == RMS$_PRV) set_errno(EACCES);
3818 else if (retsts == RMS$_DEV) set_errno(ENODEV);
3819 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3820 else set_errno(EVMSERR);
3823 retsts = sys$search(&myfab,0,0);
3824 if (!(retsts & 1) && retsts != RMS$_FNF) {
3825 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3826 #ifdef NAM$M_NO_SHORT_UPCASE
3827 if (decc_efs_case_preserve)
3828 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3830 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
3831 if (out) Safefree(out);
3832 set_vaxc_errno(retsts);
3833 if (retsts == RMS$_PRV) set_errno(EACCES);
3834 else set_errno(EVMSERR);
3838 /* If the input filespec contained any lowercase characters,
3839 * downcase the result for compatibility with Unix-minded code. */
3841 if (!decc_efs_case_preserve) {
3842 for (out = myfab.fab$l_fna; *out; out++)
3843 if (islower(*out)) { haslower = 1; break; }
3845 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3846 else { out = esa; speclen = mynam.nam$b_esl; }
3847 /* Trim off null fields added by $PARSE
3848 * If type > 1 char, must have been specified in original or default spec
3849 * (not true for version; $SEARCH may have added version of existing file).
3851 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3852 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3853 (mynam.nam$l_ver - mynam.nam$l_type == 1);
3854 if (trimver || trimtype) {
3855 if (defspec && *defspec) {
3856 char defesa[NAM$C_MAXRSS];
3857 struct FAB deffab = cc$rms_fab;
3858 struct NAM defnam = cc$rms_nam;
3860 deffab.fab$l_nam = &defnam;
3861 /* cast below ok for read only pointer */
3862 deffab.fab$l_fna = (char *)defspec; deffab.fab$b_fns = myfab.fab$b_dns;
3863 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
3864 defnam.nam$b_nop = NAM$M_SYNCHK;
3865 #ifdef NAM$M_NO_SHORT_UPCASE
3866 if (decc_efs_case_preserve)
3867 defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3869 if (sys$parse(&deffab,0,0) & 1) {
3870 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
3871 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
3875 if (*mynam.nam$l_ver != '\"')
3876 speclen = mynam.nam$l_ver - out;
3879 /* If we didn't already trim version, copy down */
3880 if (speclen > mynam.nam$l_ver - out)
3881 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
3882 speclen - (mynam.nam$l_ver - out));
3883 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
3886 /* If we just had a directory spec on input, $PARSE "helpfully"
3887 * adds an empty name and type for us */
3888 if (mynam.nam$l_name == mynam.nam$l_type &&
3889 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
3890 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
3891 speclen = mynam.nam$l_name - out;
3893 /* Posix format specifications must have matching quotes */
3894 if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
3895 if ((speclen > 1) && (out[speclen-1] != '\"')) {
3896 out[speclen] = '\"';
3901 out[speclen] = '\0';
3902 if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
3904 /* Have we been working with an expanded, but not resultant, spec? */
3905 /* Also, convert back to Unix syntax if necessary. */
3906 if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
3909 if (!mynam.nam$b_rsl) {
3911 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
3913 else strcpy(outbuf,esa);
3916 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
3917 strcpy(outbuf,tmpfspec);
3919 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3920 #ifdef NAM$M_NO_SHORT_UPCASE
3921 if (decc_efs_case_preserve)
3922 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3924 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
3925 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
3929 /* External entry points */
3930 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
3931 { return do_rmsexpand(spec,buf,0,def,opt); }
3932 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
3933 { return do_rmsexpand(spec,buf,1,def,opt); }
3937 ** The following routines are provided to make life easier when
3938 ** converting among VMS-style and Unix-style directory specifications.
3939 ** All will take input specifications in either VMS or Unix syntax. On
3940 ** failure, all return NULL. If successful, the routines listed below
3941 ** return a pointer to a buffer containing the appropriately
3942 ** reformatted spec (and, therefore, subsequent calls to that routine
3943 ** will clobber the result), while the routines of the same names with
3944 ** a _ts suffix appended will return a pointer to a mallocd string
3945 ** containing the appropriately reformatted spec.
3946 ** In all cases, only explicit syntax is altered; no check is made that
3947 ** the resulting string is valid or that the directory in question
3950 ** fileify_dirspec() - convert a directory spec into the name of the
3951 ** directory file (i.e. what you can stat() to see if it's a dir).
3952 ** The style (VMS or Unix) of the result is the same as the style
3953 ** of the parameter passed in.
3954 ** pathify_dirspec() - convert a directory spec into a path (i.e.
3955 ** what you prepend to a filename to indicate what directory it's in).
3956 ** The style (VMS or Unix) of the result is the same as the style
3957 ** of the parameter passed in.
3958 ** tounixpath() - convert a directory spec into a Unix-style path.
3959 ** tovmspath() - convert a directory spec into a VMS-style path.
3960 ** tounixspec() - convert any file spec into a Unix-style file spec.
3961 ** tovmsspec() - convert any file spec into a VMS-style spec.
3963 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
3964 ** Permission is given to distribute this code as part of the Perl
3965 ** standard distribution under the terms of the GNU General Public
3966 ** License or the Perl Artistic License. Copies of each may be
3967 ** found in the Perl standard distribution.
3970 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
3971 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
3973 static char __fileify_retbuf[NAM$C_MAXRSS+1];
3974 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
3975 char *retspec, *cp1, *cp2, *lastdir;
3976 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
3977 unsigned short int trnlnm_iter_count;
3980 if (!dir || !*dir) {
3981 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3983 dirlen = strlen(dir);
3984 while (dirlen && dir[dirlen-1] == '/') --dirlen;
3985 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3986 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
3993 if (dirlen > NAM$C_MAXRSS) {
3994 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3996 if (!strpbrk(dir+1,"/]>:") &&
3997 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
3998 strcpy(trndir,*dir == '/' ? dir + 1: dir);
3999 trnlnm_iter_count = 0;
4000 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4001 trnlnm_iter_count++;
4002 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4004 dirlen = strlen(trndir);
4007 strncpy(trndir,dir,dirlen);
4008 trndir[dirlen] = '\0';
4011 /* At this point we are done with *dir and use *trndir which is a
4012 * copy that can be modified. *dir must not be modified.
4015 /* If we were handed a rooted logical name or spec, treat it like a
4016 * simple directory, so that
4017 * $ Define myroot dev:[dir.]
4018 * ... do_fileify_dirspec("myroot",buf,1) ...
4019 * does something useful.
4021 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4022 trndir[--dirlen] = '\0';
4023 trndir[dirlen-1] = ']';
4025 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4026 trndir[--dirlen] = '\0';
4027 trndir[dirlen-1] = '>';
4030 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4031 /* If we've got an explicit filename, we can just shuffle the string. */
4032 if (*(cp1+1)) hasfilename = 1;
4033 /* Similarly, we can just back up a level if we've got multiple levels
4034 of explicit directories in a VMS spec which ends with directories. */
4036 for (cp2 = cp1; cp2 > trndir; cp2--) {
4038 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4039 *cp2 = *cp1; *cp1 = '\0';
4044 if (*cp2 == '[' || *cp2 == '<') break;
4049 cp1 = strpbrk(trndir,"]:>"); /* Prepare for future change */
4050 if (hasfilename || !cp1) { /* Unix-style path or filename */
4051 if (trndir[0] == '.') {
4052 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0'))
4053 return do_fileify_dirspec("[]",buf,ts);
4054 else if (trndir[1] == '.' &&
4055 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0')))
4056 return do_fileify_dirspec("[-]",buf,ts);
4058 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
4059 dirlen -= 1; /* to last element */
4060 lastdir = strrchr(trndir,'/');
4062 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4063 /* If we have "/." or "/..", VMSify it and let the VMS code
4064 * below expand it, rather than repeating the code to handle
4065 * relative components of a filespec here */
4067 if (*(cp1+2) == '.') cp1++;
4068 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4069 if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
4070 if (strchr(vmsdir,'/') != NULL) {
4071 /* If do_tovmsspec() returned it, it must have VMS syntax
4072 * delimiters in it, so it's a mixed VMS/Unix spec. We take
4073 * the time to check this here only so we avoid a recursion
4074 * loop; otherwise, gigo.
4076 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
4078 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
4079 return do_tounixspec(trndir,buf,ts);
4082 } while ((cp1 = strstr(cp1,"/.")) != NULL);
4083 lastdir = strrchr(trndir,'/');
4085 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4086 /* Ditto for specs that end in an MFD -- let the VMS code
4087 * figure out whether it's a real device or a rooted logical. */
4089 /* This should not happen any more. Allowing the fake /000000
4090 * in a UNIX pathname causes all sorts of problems when trying
4091 * to run in UNIX emulation. So the VMS to UNIX conversions
4092 * now remove the fake /000000 directories.
4095 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4096 if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
4097 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
4098 return do_tounixspec(trndir,buf,ts);
4102 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4103 !(lastdir = cp1 = strrchr(trndir,']')) &&
4104 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4105 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
4108 /* For EFS or ODS-5 look for the last dot */
4109 if (decc_efs_charset) {
4110 cp2 = strrchr(cp1,'.');
4112 if (vms_process_case_tolerant) {
4113 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4114 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4115 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4116 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4117 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4118 (ver || *cp3)))))) {
4120 set_vaxc_errno(RMS$_DIR);
4125 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4126 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4127 !*(cp2+3) || *(cp2+3) != 'R' ||
4128 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4129 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4130 (ver || *cp3)))))) {
4132 set_vaxc_errno(RMS$_DIR);
4136 dirlen = cp2 - trndir;
4140 retlen = dirlen + 6;
4141 if (buf) retspec = buf;
4142 else if (ts) Newx(retspec,retlen+1,char);
4143 else retspec = __fileify_retbuf;
4144 memcpy(retspec,trndir,dirlen);
4145 retspec[dirlen] = '\0';
4147 /* We've picked up everything up to the directory file name.
4148 Now just add the type and version, and we're set. */
4149 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4150 strcat(retspec,".dir;1");
4152 strcat(retspec,".DIR;1");
4155 else { /* VMS-style directory spec */
4156 char esa[NAM$C_MAXRSS+1], term, *cp;
4157 unsigned long int sts, cmplen, haslower = 0;
4158 struct FAB dirfab = cc$rms_fab;
4159 struct NAM savnam, dirnam = cc$rms_nam;
4161 dirfab.fab$b_fns = strlen(trndir);
4162 dirfab.fab$l_fna = trndir;
4163 dirfab.fab$l_nam = &dirnam;
4164 dirfab.fab$l_dna = ".DIR;1";
4165 dirfab.fab$b_dns = 6;
4166 dirnam.nam$b_ess = NAM$C_MAXRSS;
4167 dirnam.nam$l_esa = esa;
4168 #ifdef NAM$M_NO_SHORT_UPCASE
4169 if (decc_efs_case_preserve)
4170 dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4173 for (cp = trndir; *cp; cp++)
4174 if (islower(*cp)) { haslower = 1; break; }
4175 if (!((sts = sys$parse(&dirfab))&1)) {
4176 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4177 dirnam.nam$b_nop |= NAM$M_SYNCHK;
4178 sts = sys$parse(&dirfab) & 1;
4182 set_vaxc_errno(dirfab.fab$l_sts);
4188 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
4189 /* Yes; fake the fnb bits so we'll check type below */
4190 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
4192 else { /* No; just work with potential name */
4193 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4195 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
4196 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
4197 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
4202 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4203 cp1 = strchr(esa,']');
4204 if (!cp1) cp1 = strchr(esa,'>');
4205 if (cp1) { /* Should always be true */
4206 dirnam.nam$b_esl -= cp1 - esa - 1;
4207 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
4210 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
4211 /* Yep; check version while we're at it, if it's there. */
4212 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
4213 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
4214 /* Something other than .DIR[;1]. Bzzt. */
4215 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
4216 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
4218 set_vaxc_errno(RMS$_DIR);
4222 esa[dirnam.nam$b_esl] = '\0';
4223 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
4224 /* They provided at least the name; we added the type, if necessary, */
4225 if (buf) retspec = buf; /* in sys$parse() */
4226 else if (ts) Newx(retspec,dirnam.nam$b_esl+1,char);
4227 else retspec = __fileify_retbuf;
4228 strcpy(retspec,esa);
4229 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
4230 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
4233 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4234 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4236 dirnam.nam$b_esl -= 9;
4238 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4239 if (cp1 == NULL) { /* should never happen */
4240 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
4241 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
4246 retlen = strlen(esa);
4247 cp1 = strrchr(esa,'.');
4248 /* ODS-5 directory specifications can have extra "." in them. */
4249 while (cp1 != NULL) {
4250 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4254 while ((cp1 > esa) && (*cp1 != '.'))
4261 if ((cp1) != NULL) {
4262 /* There's more than one directory in the path. Just roll back. */
4264 if (buf) retspec = buf;
4265 else if (ts) Newx(retspec,retlen+7,char);
4266 else retspec = __fileify_retbuf;
4267 strcpy(retspec,esa);
4270 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
4271 /* Go back and expand rooted logical name */
4272 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
4273 #ifdef NAM$M_NO_SHORT_UPCASE
4274 if (decc_efs_case_preserve)
4275 dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4277 if (!(sys$parse(&dirfab) & 1)) {
4278 dirnam.nam$l_rlf = NULL;
4279 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
4281 set_vaxc_errno(dirfab.fab$l_sts);
4284 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
4285 if (buf) retspec = buf;
4286 else if (ts) Newx(retspec,retlen+16,char);
4287 else retspec = __fileify_retbuf;
4288 cp1 = strstr(esa,"][");
4289 if (!cp1) cp1 = strstr(esa,"]<");
4291 memcpy(retspec,esa,dirlen);
4292 if (!strncmp(cp1+2,"000000]",7)) {
4293 retspec[dirlen-1] = '\0';
4294 /* Not full ODS-5, just extra dots in directories for now */
4295 cp1 = retspec + dirlen - 1;
4296 while (cp1 > retspec)
4301 if (*(cp1-1) != '^')
4306 if (*cp1 == '.') *cp1 = ']';
4308 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4309 memcpy(cp1+1,"000000]",7);
4313 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
4314 retspec[retlen] = '\0';
4315 /* Convert last '.' to ']' */
4316 cp1 = retspec+retlen-1;
4317 while (*cp != '[') {
4320 /* Do not trip on extra dots in ODS-5 directories */
4321 if ((cp1 == retspec) || (*(cp1-1) != '^'))
4325 if (*cp1 == '.') *cp1 = ']';
4327 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4328 memcpy(cp1+1,"000000]",7);
4332 else { /* This is a top-level dir. Add the MFD to the path. */
4333 if (buf) retspec = buf;
4334 else if (ts) Newx(retspec,retlen+16,char);
4335 else retspec = __fileify_retbuf;
4338 while (*cp1 != ':') *(cp2++) = *(cp1++);
4339 strcpy(cp2,":[000000]");
4344 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
4345 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
4346 /* We've set up the string up through the filename. Add the
4347 type and version, and we're done. */
4348 strcat(retspec,".DIR;1");
4350 /* $PARSE may have upcased filespec, so convert output to lower
4351 * case if input contained any lowercase characters. */
4352 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
4355 } /* end of do_fileify_dirspec() */
4357 /* External entry points */
4358 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
4359 { return do_fileify_dirspec(dir,buf,0); }
4360 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
4361 { return do_fileify_dirspec(dir,buf,1); }
4363 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
4364 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
4366 static char __pathify_retbuf[NAM$C_MAXRSS+1];
4367 unsigned long int retlen;
4368 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
4369 unsigned short int trnlnm_iter_count;
4373 if (!dir || !*dir) {
4374 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4377 if (*dir) strcpy(trndir,dir);
4378 else getcwd(trndir,sizeof trndir - 1);
4380 trnlnm_iter_count = 0;
4381 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
4382 && my_trnlnm(trndir,trndir,0)) {
4383 trnlnm_iter_count++;
4384 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4385 trnlen = strlen(trndir);
4387 /* Trap simple rooted lnms, and return lnm:[000000] */
4388 if (!strcmp(trndir+trnlen-2,".]")) {
4389 if (buf) retpath = buf;
4390 else if (ts) Newx(retpath,strlen(dir)+10,char);
4391 else retpath = __pathify_retbuf;
4392 strcpy(retpath,dir);
4393 strcat(retpath,":[000000]");
4398 /* At this point we do not work with *dir, but the copy in
4399 * *trndir that is modifiable.
4402 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
4403 if (*trndir == '.' && (*(trndir+1) == '\0' ||
4404 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
4405 retlen = 2 + (*(trndir+1) != '\0');
4407 if ( !(cp1 = strrchr(trndir,'/')) &&
4408 !(cp1 = strrchr(trndir,']')) &&
4409 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
4410 if ((cp2 = strchr(cp1,'.')) != NULL &&
4411 (*(cp2-1) != '/' || /* Trailing '.', '..', */
4412 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
4413 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
4414 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
4417 /* For EFS or ODS-5 look for the last dot */
4418 if (decc_efs_charset) {
4419 cp2 = strrchr(cp1,'.');
4421 if (vms_process_case_tolerant) {
4422 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4423 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4424 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4425 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4426 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4427 (ver || *cp3)))))) {
4429 set_vaxc_errno(RMS$_DIR);
4434 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4435 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4436 !*(cp2+3) || *(cp2+3) != 'R' ||
4437 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4438 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4439 (ver || *cp3)))))) {
4441 set_vaxc_errno(RMS$_DIR);
4445 retlen = cp2 - trndir + 1;
4447 else { /* No file type present. Treat the filename as a directory. */
4448 retlen = strlen(trndir) + 1;
4451 if (buf) retpath = buf;
4452 else if (ts) Newx(retpath,retlen+1,char);
4453 else retpath = __pathify_retbuf;
4454 strncpy(retpath, trndir, retlen-1);
4455 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
4456 retpath[retlen-1] = '/'; /* with '/', add it. */
4457 retpath[retlen] = '\0';
4459 else retpath[retlen-1] = '\0';
4461 else { /* VMS-style directory spec */
4462 char esa[NAM$C_MAXRSS+1], *cp;
4463 unsigned long int sts, cmplen, haslower;
4464 struct FAB dirfab = cc$rms_fab;
4465 struct NAM savnam, dirnam = cc$rms_nam;
4467 /* If we've got an explicit filename, we can just shuffle the string. */
4468 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
4469 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
4470 if ((cp2 = strchr(cp1,'.')) != NULL) {
4472 if (vms_process_case_tolerant) {
4473 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4474 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4475 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4476 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4477 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4478 (ver || *cp3)))))) {
4480 set_vaxc_errno(RMS$_DIR);
4485 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4486 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4487 !*(cp2+3) || *(cp2+3) != 'R' ||
4488 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4489 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4490 (ver || *cp3)))))) {
4492 set_vaxc_errno(RMS$_DIR);
4497 else { /* No file type, so just draw name into directory part */
4498 for (cp2 = cp1; *cp2; cp2++) ;
4501 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
4503 /* We've now got a VMS 'path'; fall through */
4505 dirfab.fab$b_fns = strlen(trndir);
4506 dirfab.fab$l_fna = trndir;
4507 if (trndir[dirfab.fab$b_fns-1] == ']' ||
4508 trndir[dirfab.fab$b_fns-1] == '>' ||
4509 trndir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
4510 if (buf) retpath = buf;
4511 else if (ts) Newx(retpath,strlen(trndir)+1,char);
4512 else retpath = __pathify_retbuf;
4513 strcpy(retpath,trndir);
4516 dirfab.fab$l_dna = ".DIR;1";
4517 dirfab.fab$b_dns = 6;
4518 dirfab.fab$l_nam = &dirnam;
4519 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
4520 dirnam.nam$l_esa = esa;
4521 #ifdef NAM$M_NO_SHORT_UPCASE
4522 if (decc_efs_case_preserve)
4523 dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4526 for (cp = trndir; *cp; cp++)
4527 if (islower(*cp)) { haslower = 1; break; }
4529 if (!(sts = (sys$parse(&dirfab)&1))) {
4530 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4531 dirnam.nam$b_nop |= NAM$M_SYNCHK;
4532 sts = sys$parse(&dirfab) & 1;
4536 set_vaxc_errno(dirfab.fab$l_sts);
4542 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
4543 if (dirfab.fab$l_sts != RMS$_FNF) {
4545 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
4546 dirfab.fab$b_dns = 0;
4547 sts1 = sys$parse(&dirfab,0,0);
4549 set_vaxc_errno(dirfab.fab$l_sts);
4552 dirnam = savnam; /* No; just work with potential name */
4555 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
4556 /* Yep; check version while we're at it, if it's there. */
4557 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
4558 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
4560 /* Something other than .DIR[;1]. Bzzt. */
4561 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
4562 dirfab.fab$b_dns = 0;
4563 sts2 = sys$parse(&dirfab,0,0);
4565 set_vaxc_errno(RMS$_DIR);
4569 /* OK, the type was fine. Now pull any file name into the
4571 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
4573 cp1 = strrchr(esa,'>');
4574 *dirnam.nam$l_type = '>';
4577 *(dirnam.nam$l_type + 1) = '\0';
4578 retlen = dirnam.nam$l_type - esa + 2;
4579 if (buf) retpath = buf;
4580 else if (ts) Newx(retpath,retlen,char);
4581 else retpath = __pathify_retbuf;
4582 strcpy(retpath,esa);
4583 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
4584 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
4585 /* $PARSE may have upcased filespec, so convert output to lower
4586 * case if input contained any lowercase characters. */
4587 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
4591 } /* end of do_pathify_dirspec() */
4593 /* External entry points */
4594 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
4595 { return do_pathify_dirspec(dir,buf,0); }
4596 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
4597 { return do_pathify_dirspec(dir,buf,1); }
4599 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
4600 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
4602 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
4603 char *dirend, *rslt, *cp1, *cp3, tmp[NAM$C_MAXRSS+1];
4605 int devlen, dirlen, retlen = NAM$C_MAXRSS+1;
4606 int expand = 1; /* guarantee room for leading and trailing slashes */
4607 unsigned short int trnlnm_iter_count;
4610 if (spec == NULL) return NULL;
4611 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
4612 if (buf) rslt = buf;
4614 retlen = strlen(spec);
4615 cp1 = strchr(spec,'[');
4616 if (!cp1) cp1 = strchr(spec,'<');
4618 for (cp1++; *cp1; cp1++) {
4619 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
4620 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
4621 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
4624 Newx(rslt,retlen+2+2*expand,char);
4626 else rslt = __tounixspec_retbuf;
4628 /* New VMS specific format needs translation
4629 * glob passes filenames with trailing '\n' and expects this preserved.
4631 if (decc_posix_compliant_pathnames) {
4632 if (strncmp(spec, "\"^UP^", 5) == 0) {
4638 Newx(tunix, VMS_MAXRSS + 1,char);
4639 strcpy(tunix, spec);
4640 tunix_len = strlen(tunix);
4642 if (tunix[tunix_len - 1] == '\n') {
4643 tunix[tunix_len - 1] = '\"';
4644 tunix[tunix_len] = '\0';
4648 uspec = decc$translate_vms(tunix);
4650 if ((int)uspec > 0) {
4656 /* If we can not translate it, makemaker wants as-is */
4664 cmp_rslt = 0; /* Presume VMS */
4665 cp1 = strchr(spec, '/');
4669 /* Look for EFS ^/ */
4670 if (decc_efs_charset) {
4671 while (cp1 != NULL) {
4674 /* Found illegal VMS, assume UNIX */
4679 cp1 = strchr(cp1, '/');
4683 /* Look for "." and ".." */
4684 if (decc_filename_unix_report) {
4685 if (spec[0] == '.') {
4686 if ((spec[1] == '\0') || (spec[1] == '\n')) {
4690 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
4696 /* This is already UNIX or at least nothing VMS understands */
4704 dirend = strrchr(spec,']');
4705 if (dirend == NULL) dirend = strrchr(spec,'>');
4706 if (dirend == NULL) dirend = strchr(spec,':');
4707 if (dirend == NULL) {
4712 /* Special case 1 - sys$posix_root = / */
4713 #if __CRTL_VER >= 70000000
4714 if (!decc_disable_posix_root) {
4715 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
4723 /* Special case 2 - Convert NLA0: to /dev/null */
4724 #if __CRTL_VER < 70000000
4725 cmp_rslt = strncmp(spec,"NLA0:", 5);
4727 cmp_rslt = strncmp(spec,"nla0:", 5);
4729 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
4731 if (cmp_rslt == 0) {
4732 strcpy(rslt, "/dev/null");
4735 if (spec[6] != '\0') {
4742 /* Also handle special case "SYS$SCRATCH:" */
4743 #if __CRTL_VER < 70000000
4744 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
4746 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
4748 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
4750 if (cmp_rslt == 0) {
4753 islnm = my_trnlnm(tmp, "TMP", 0);
4755 strcpy(rslt, "/tmp");
4758 if (spec[12] != '\0') {
4766 if (*cp2 != '[' && *cp2 != '<') {
4769 else { /* the VMS spec begins with directories */
4771 if (*cp2 == ']' || *cp2 == '>') {
4772 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
4775 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
4776 if (getcwd(tmp,sizeof tmp,1) == NULL) {
4777 if (ts) Safefree(rslt);
4780 trnlnm_iter_count = 0;
4783 while (*cp3 != ':' && *cp3) cp3++;
4785 if (strchr(cp3,']') != NULL) break;
4786 trnlnm_iter_count++;
4787 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
4788 } while (vmstrnenv(tmp,tmp,0,fildev,0));
4790 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
4791 retlen = devlen + dirlen;
4792 Renew(rslt,retlen+1+2*expand,char);
4798 *(cp1++) = *(cp3++);
4799 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
4803 if ((*cp2 == '^')) {
4804 /* EFS file escape, pass the next character as is */
4805 /* Fix me: HEX encoding for UNICODE not implemented */
4808 else if ( *cp2 == '.') {
4809 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
4810 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
4816 for (; cp2 <= dirend; cp2++) {
4817 if ((*cp2 == '^')) {
4818 /* EFS file escape, pass the next character as is */
4819 /* Fix me: HEX encoding for UNICODE not implemented */
4825 if (*(cp2+1) == '[') cp2++;
4827 else if (*cp2 == ']' || *cp2 == '>') {
4828 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
4830 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
4832 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
4833 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
4834 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
4835 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
4836 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
4838 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
4839 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
4843 else if (*cp2 == '-') {
4844 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
4845 while (*cp2 == '-') {
4847 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
4849 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
4850 if (ts) Safefree(rslt); /* filespecs like */
4851 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
4855 else *(cp1++) = *cp2;
4857 else *(cp1++) = *cp2;
4859 while (*cp2) *(cp1++) = *(cp2++);
4862 /* This still leaves /000000/ when working with a
4863 * VMS device root or concealed root.
4869 ulen = strlen(rslt);
4871 /* Get rid of "000000/ in rooted filespecs */
4873 zeros = strstr(rslt, "/000000/");
4874 if (zeros != NULL) {
4876 mlen = ulen - (zeros - rslt) - 7;
4877 memmove(zeros, &zeros[7], mlen);
4886 } /* end of do_tounixspec() */
4888 /* External entry points */
4889 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
4890 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
4892 #if __CRTL_VER >= 80200000 && !defined(__VAX)
4894 static int posix_to_vmsspec
4895 (char *vmspath, int vmspath_len, const char *unixpath) {
4897 struct FAB myfab = cc$rms_fab;
4898 struct NAML mynam = cc$rms_naml;
4899 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4900 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4906 /* If not a posix spec already, convert it */
4908 unixlen = strlen(unixpath);
4913 if (strncmp(unixpath,"\"^UP^",5) != 0) {
4914 sprintf(vmspath,"\"^UP^%s\"",unixpath);
4917 /* This is already a VMS specification, no conversion */
4919 strncpy(vmspath,unixpath, vmspath_len);
4921 vmspath[vmspath_len] = 0;
4922 if (unixpath[unixlen - 1] == '/')
4924 Newx(esa, VMS_MAXRSS+1, char);
4925 myfab.fab$l_fna = vmspath;
4926 myfab.fab$b_fns = strlen(vmspath);
4927 myfab.fab$l_naml = &mynam;
4928 mynam.naml$l_esa = NULL;
4929 mynam.naml$b_ess = 0;
4930 mynam.naml$l_long_expand = esa;
4931 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS;
4932 mynam.naml$l_rsa = NULL;
4933 mynam.naml$b_rss = 0;
4934 if (decc_efs_case_preserve)
4935 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
4936 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
4938 /* Set up the remaining naml fields */
4939 sts = sys$parse(&myfab);
4941 /* It failed! Try again as a UNIX filespec */
4947 /* get the Device ID and the FID */
4948 sts = sys$search(&myfab);
4949 /* on any failure, returned the POSIX ^UP^ filespec */
4954 specdsc.dsc$a_pointer = vmspath;
4955 specdsc.dsc$w_length = vmspath_len;
4957 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
4958 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
4959 sts = lib$fid_to_name
4960 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
4962 /* on any failure, returned the POSIX ^UP^ filespec */
4964 /* This can happen if user does not have permission to read directories */
4965 if (strncmp(unixpath,"\"^UP^",5) != 0)
4966 sprintf(vmspath,"\"^UP^%s\"",unixpath);
4968 strcpy(vmspath, unixpath);
4971 vmspath[specdsc.dsc$w_length] = 0;
4973 /* Are we expecting a directory? */
4974 if (dir_flag != 0) {
4980 i = specdsc.dsc$w_length - 1;
4984 /* Version must be '1' */
4985 if (vmspath[i--] != '1')
4987 /* Version delimiter is one of ".;" */
4988 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
4991 if (vmspath[i--] != 'R')
4993 if (vmspath[i--] != 'I')
4995 if (vmspath[i--] != 'D')
4997 if (vmspath[i--] != '.')
4999 eptr = &vmspath[i+1];
5001 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5002 if (vmspath[i-1] != '^') {
5010 /* Get rid of 6 imaginary zero directory filename */
5011 vmspath[i+1] = '\0';
5015 if (vmspath[i] == '0')
5029 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5030 static int posix_to_vmsspec_hardway
5031 (char *vmspath, int vmspath_len, const char *unixpath) {
5034 const char *unixptr;
5036 const char *lastslash;
5037 const char *lastdot;
5048 /* Ignore leading "/" characters */
5049 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5052 unixlen = strlen(unixptr);
5054 /* Do nothing with blank paths */
5060 lastslash = strrchr(unixptr,'/');
5061 lastdot = strrchr(unixptr,'.');
5064 /* last dot is last dot or past end of string */
5065 if (lastdot == NULL)
5066 lastdot = unixptr + unixlen;
5068 /* if no directories, set last slash to beginning of string */
5069 if (lastslash == NULL) {
5070 lastslash = unixptr;
5073 /* Watch out for trailing "." after last slash, still a directory */
5074 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5075 lastslash = unixptr + unixlen;
5078 /* Watch out for traiing ".." after last slash, still a directory */
5079 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5080 lastslash = unixptr + unixlen;
5083 /* dots in directories are aways escaped */
5084 if (lastdot < lastslash)
5085 lastdot = unixptr + unixlen;
5088 /* if (unixptr < lastslash) then we are in a directory */
5096 /* This could have a "^UP^ on the front */
5097 if (strncmp(unixptr,"\"^UP^",5) == 0) {
5102 /* Start with the UNIX path */
5103 if (*unixptr != '/') {
5104 /* relative paths */
5105 if (lastslash > unixptr) {
5108 /* skip leading ./ */
5110 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5116 /* Are we still in a directory? */
5117 if (unixptr <= lastslash) {
5122 /* if not backing up, then it is relative forward. */
5123 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5124 ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5132 /* Perl wants an empty directory here to tell the difference
5133 * between a DCL commmand and a filename
5142 /* Handle two special files . and .. */
5143 if (unixptr[0] == '.') {
5144 if (unixptr[1] == '\0') {
5151 if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5162 else { /* Absolute PATH handling */
5166 /* Need to find out where root is */
5168 /* In theory, this procedure should never get an absolute POSIX pathname
5169 * that can not be found on the POSIX root.
5170 * In practice, that can not be relied on, and things will show up
5171 * here that are a VMS device name or concealed logical name instead.
5172 * So to make things work, this procedure must be tolerant.
5174 Newx(esa, vmspath_len, char);
5177 nextslash = strchr(&unixptr[1],'/');
5179 if (nextslash != NULL) {
5180 seg_len = nextslash - &unixptr[1];
5181 strncpy(vmspath, unixptr, seg_len + 1);
5182 vmspath[seg_len+1] = 0;
5183 sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5187 /* This is verified to be a real path */
5189 sts = posix_to_vmsspec(esa, vmspath_len, "/");
5190 strcpy(vmspath, esa);
5191 vmslen = strlen(vmspath);
5192 vmsptr = vmspath + vmslen;
5194 if (unixptr < lastslash) {
5203 cmp = strcmp(rptr,"000000.");
5208 } /* removing 6 zeros */
5209 } /* vmslen < 7, no 6 zeros possible */
5210 } /* Not in a directory */
5211 } /* end of verified real path handling */
5216 /* Ok, we have a device or a concealed root that is not in POSIX
5217 * or we have garbage. Make the best of it.
5220 /* Posix to VMS destroyed this, so copy it again */
5221 strncpy(vmspath, &unixptr[1], seg_len);
5222 vmspath[seg_len] = 0;
5224 vmsptr = &vmsptr[vmslen];
5227 /* Now do we need to add the fake 6 zero directory to it? */
5229 if ((*lastslash == '/') && (nextslash < lastslash)) {
5230 /* No there is another directory */
5236 /* now we have foo:bar or foo:[000000]bar to decide from */
5237 islnm = my_trnlnm(vmspath, esa, 0);
5238 trnend = islnm ? strlen(esa) - 1 : 0;
5240 /* if this was a logical name, ']' or '>' must be present */
5241 /* if not a logical name, then assume a device and hope. */
5242 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
5244 /* if log name and trailing '.' then rooted - treat as device */
5245 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
5247 /* Fix me, if not a logical name, a device lookup should be
5248 * done to see if the device is file structured. If the device
5249 * is not file structured, the 6 zeros should not be put on.
5251 * As it is, perl is occasionally looking for dev:[000000]tty.
5252 * which looks a little strange.
5255 if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
5256 /* No real directory present */
5261 /* Put the device delimiter on */
5264 unixptr = nextslash;
5267 /* Start directory if needed */
5268 if (!islnm || add_6zero) {
5274 /* add fake 000000] if needed */
5287 } /* non-POSIX translation */
5289 } /* End of relative/absolute path handling */
5291 while ((*unixptr) && (vmslen < vmspath_len)){
5296 if (dir_start != 0) {
5298 /* First characters in a directory are handled special */
5299 while ((*unixptr == '/') ||
5300 ((*unixptr == '.') &&
5301 ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
5306 /* Skip redundant / in specification */
5307 while ((*unixptr == '/') && (dir_start != 0)) {
5310 if (unixptr == lastslash)
5313 if (unixptr == lastslash)
5316 /* Skip redundant ./ characters */
5317 while ((*unixptr == '.') &&
5318 ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
5321 if (unixptr == lastslash)
5323 if (*unixptr == '/')
5326 if (unixptr == lastslash)
5329 /* Skip redundant ../ characters */
5330 while ((*unixptr == '.') && (unixptr[1] == '.') &&
5331 ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
5332 /* Set the backing up flag */
5338 unixptr++; /* first . */
5339 unixptr++; /* second . */
5340 if (unixptr == lastslash)
5342 if (*unixptr == '/') /* The slash */
5345 if (unixptr == lastslash)
5348 /* To do: Perl expects /.../ to be translated to [...] on VMS */
5349 /* Not needed when VMS is pretending to be UNIX. */
5351 /* Is this loop stuck because of too many dots? */
5352 if (loop_flag == 0) {
5353 /* Exit the loop and pass the rest through */
5358 /* Are we done with directories yet? */
5359 if (unixptr >= lastslash) {
5361 /* Watch out for trailing dots */
5370 if (*unixptr == '/')
5374 /* Have we stopped backing up? */
5379 /* dir_start continues to be = 1 */
5381 if (*unixptr == '-') {
5383 *vmsptr++ = *unixptr++;
5387 /* Now are we done with directories yet? */
5388 if (unixptr >= lastslash) {
5390 /* Watch out for trailing dots */
5406 if (*unixptr == '\0')
5409 /* Normal characters - More EFS work probably needed */
5415 /* remove multiple / */
5416 while (unixptr[1] == '/') {
5419 if (unixptr == lastslash) {
5420 /* Watch out for trailing dots */
5432 /* To do: Perl expects /.../ to be translated to [...] on VMS */
5433 /* Not needed when VMS is pretending to be UNIX. */
5437 if (*unixptr != '\0')
5453 if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
5459 /* trailing dot ==> '^..' on VMS */
5460 if (*unixptr == '\0') {
5464 *vmsptr++ = *unixptr++;
5467 if (quoted && (unixptr[1] == '\0')) {
5472 *vmsptr++ = *unixptr++;
5479 *vmsptr++ = *unixptr++;
5483 if (*unixptr != '\0') {
5484 *vmsptr++ = *unixptr++;
5491 /* Make sure directory is closed */
5492 if (unixptr == lastslash) {
5494 vmsptr2 = vmsptr - 1;
5496 if (*vmsptr2 != ']') {
5499 /* directories do not end in a dot bracket */
5500 if (*vmsptr2 == '.') {
5504 if (*vmsptr2 != '^') {
5505 vmsptr--; /* back up over the dot */
5513 /* Add a trailing dot if a file with no extension */
5514 vmsptr2 = vmsptr - 1;
5515 if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
5516 (*lastdot != '.')) {
5527 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
5528 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
5529 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
5530 char *rslt, *dirend;
5535 unsigned long int infront = 0, hasdir = 1;
5539 if (path == NULL) return NULL;
5540 rslt_len = VMS_MAXRSS;
5541 if (buf) rslt = buf;
5542 else if (ts) Newx(rslt,NAM$C_MAXRSS+1,char);
5543 else rslt = __tovmsspec_retbuf;
5544 if (strpbrk(path,"]:>") ||
5545 (dirend = strrchr(path,'/')) == NULL) {
5546 if (path[0] == '.') {
5547 if (path[1] == '\0') strcpy(rslt,"[]");
5548 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
5549 else strcpy(rslt,path); /* probably garbage */
5551 else strcpy(rslt,path);
5555 /* Posix specifications are now a native VMS format */
5556 /*--------------------------------------------------*/
5557 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5558 if (decc_posix_compliant_pathnames) {
5559 if (strncmp(path,"\"^UP^",5) == 0) {
5560 posix_to_vmsspec_hardway(rslt, rslt_len, path);
5566 vms_delim = strpbrk(path,"]:>");
5568 if ((vms_delim != NULL) ||
5569 ((dirend = strrchr(path,'/')) == NULL)) {
5571 /* VMS special characters found! */
5573 if (path[0] == '.') {
5574 if (path[1] == '\0') strcpy(rslt,"[]");
5575 else if (path[1] == '.' && path[2] == '\0')
5578 /* Dot preceeding a device or directory ? */
5580 /* If not in POSIX mode, pass it through and hope it works */
5581 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5582 if (!decc_posix_compliant_pathnames)
5583 strcpy(rslt,path); /* probably garbage */
5585 posix_to_vmsspec_hardway(rslt, rslt_len, path);
5587 strcpy(rslt,path); /* probably garbage */
5593 /* If no VMS characters and in POSIX mode, convert it!
5594 * This is the easiest way to get directory specifications
5595 * handled correctly in POSIX mode
5597 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5598 if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
5599 posix_to_vmsspec_hardway(rslt, rslt_len, path);
5601 /* No unix path separators - presume VMS already */
5605 strcpy(rslt,path); /* probably garbage */
5611 /* If POSIX mode active, handle the conversion */
5612 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5613 if (decc_posix_compliant_pathnames) {
5614 posix_to_vmsspec_hardway(rslt, rslt_len, path);
5619 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
5620 if (!*(dirend+2)) dirend +=2;
5621 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
5622 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
5627 lastdot = strrchr(cp2,'.');
5629 char trndev[NAM$C_MAXRSS+1];
5633 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
5635 if (decc_disable_posix_root) {
5636 strcpy(rslt,"sys$disk:[000000]");
5639 strcpy(rslt,"sys$posix_root:[000000]");
5643 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
5645 islnm = my_trnlnm(rslt,trndev,0);
5647 /* DECC special handling */
5649 if (strcmp(rslt,"bin") == 0) {
5650 strcpy(rslt,"sys$system");
5653 islnm = my_trnlnm(rslt,trndev,0);
5655 else if (strcmp(rslt,"tmp") == 0) {
5656 strcpy(rslt,"sys$scratch");
5659 islnm = my_trnlnm(rslt,trndev,0);
5661 else if (!decc_disable_posix_root) {
5662 strcpy(rslt, "sys$posix_root");
5666 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
5667 islnm = my_trnlnm(rslt,trndev,0);
5669 else if (strcmp(rslt,"dev") == 0) {
5670 if (strncmp(cp2,"/null", 5) == 0) {
5671 if ((cp2[5] == 0) || (cp2[5] == '/')) {
5672 strcpy(rslt,"NLA0");
5676 islnm = my_trnlnm(rslt,trndev,0);
5682 trnend = islnm ? strlen(trndev) - 1 : 0;
5683 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
5684 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
5685 /* If the first element of the path is a logical name, determine
5686 * whether it has to be translated so we can add more directories. */
5687 if (!islnm || rooted) {
5690 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
5694 if (cp2 != dirend) {
5695 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
5696 strcpy(rslt,trndev);
5697 cp1 = rslt + trnend;
5704 if (decc_disable_posix_root) {
5714 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
5715 cp2 += 2; /* skip over "./" - it's redundant */
5716 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
5718 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
5719 *(cp1++) = '-'; /* "../" --> "-" */
5722 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
5723 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
5724 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
5725 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
5728 else if ((cp2 != lastdot) || (lastdot < dirend)) {
5729 /* Escape the extra dots in EFS file specifications */
5732 if (cp2 > dirend) cp2 = dirend;
5734 else *(cp1++) = '.';
5736 for (; cp2 < dirend; cp2++) {
5738 if (*(cp2-1) == '/') continue;
5739 if (*(cp1-1) != '.') *(cp1++) = '.';
5742 else if (!infront && *cp2 == '.') {
5743 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
5744 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
5745 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
5746 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
5747 else if (*(cp1-2) == '[') *(cp1-1) = '-';
5748 else { /* back up over previous directory name */
5750 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
5751 if (*(cp1-1) == '[') {
5752 memcpy(cp1,"000000.",7);
5757 if (cp2 == dirend) break;
5759 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
5760 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
5761 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
5762 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
5764 *(cp1++) = '.'; /* Simulate trailing '/' */
5765 cp2 += 2; /* for loop will incr this to == dirend */
5767 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
5770 if (decc_efs_charset == 0)
5771 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
5773 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
5779 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
5781 if (decc_efs_charset == 0)
5788 else *(cp1++) = *cp2;
5792 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
5793 if (hasdir) *(cp1++) = ']';
5794 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
5795 /* fixme for ODS5 */
5810 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
5811 decc_readdir_dropdotnotype) {
5816 /* trailing dot ==> '^..' on VMS */
5823 *(cp1++) = *(cp2++);
5851 *(cp1++) = *(cp2++);
5854 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
5855 * which is wrong. UNIX notation should be ".dir. unless
5856 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
5857 * changing this behavior could break more things at this time.
5858 * efs character set effectively does not allow "." to be a version
5859 * delimiter as a further complication about changing this.
5861 if (decc_filename_unix_report != 0) {
5864 *(cp1++) = *(cp2++);
5867 *(cp1++) = *(cp2++);
5870 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
5874 /* Fix me for "^]", but that requires making sure that you do
5875 * not back up past the start of the filename
5877 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
5884 } /* end of do_tovmsspec() */
5886 /* External entry points */
5887 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
5888 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
5890 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
5891 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
5892 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
5894 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
5896 if (path == NULL) return NULL;
5897 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
5898 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
5899 if (buf) return buf;
5901 vmslen = strlen(vmsified);
5902 Newx(cp,vmslen+1,char);
5903 memcpy(cp,vmsified,vmslen);
5908 strcpy(__tovmspath_retbuf,vmsified);
5909 return __tovmspath_retbuf;
5912 } /* end of do_tovmspath() */
5914 /* External entry points */
5915 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
5916 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
5919 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
5920 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
5921 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
5923 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
5925 if (path == NULL) return NULL;
5926 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
5927 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
5928 if (buf) return buf;
5930 unixlen = strlen(unixified);
5931 Newx(cp,unixlen+1,char);
5932 memcpy(cp,unixified,unixlen);
5937 strcpy(__tounixpath_retbuf,unixified);
5938 return __tounixpath_retbuf;
5941 } /* end of do_tounixpath() */
5943 /* External entry points */
5944 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
5945 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
5948 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
5950 *****************************************************************************
5952 * Copyright (C) 1989-1994 by *
5953 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
5955 * Permission is hereby granted for the reproduction of this software, *
5956 * on condition that this copyright notice is included in the reproduction, *
5957 * and that such reproduction is not for purposes of profit or material *
5960 * 27-Aug-1994 Modified for inclusion in perl5 *
5961 * by Charles Bailey bailey@newman.upenn.edu *
5962 *****************************************************************************
5966 * getredirection() is intended to aid in porting C programs
5967 * to VMS (Vax-11 C). The native VMS environment does not support
5968 * '>' and '<' I/O redirection, or command line wild card expansion,
5969 * or a command line pipe mechanism using the '|' AND background
5970 * command execution '&'. All of these capabilities are provided to any
5971 * C program which calls this procedure as the first thing in the
5973 * The piping mechanism will probably work with almost any 'filter' type
5974 * of program. With suitable modification, it may useful for other
5975 * portability problems as well.
5977 * Author: Mark Pizzolato mark@infocomm.com
5981 struct list_item *next;
5985 static void add_item(struct list_item **head,
5986 struct list_item **tail,
5990 static void mp_expand_wild_cards(pTHX_ char *item,
5991 struct list_item **head,
5992 struct list_item **tail,
5995 static int background_process(pTHX_ int argc, char **argv);
5997 static void pipe_and_fork(pTHX_ char **cmargv);
5999 /*{{{ void getredirection(int *ac, char ***av)*/
6001 mp_getredirection(pTHX_ int *ac, char ***av)
6003 * Process vms redirection arg's. Exit if any error is seen.
6004 * If getredirection() processes an argument, it is erased
6005 * from the vector. getredirection() returns a new argc and argv value.
6006 * In the event that a background command is requested (by a trailing "&"),
6007 * this routine creates a background subprocess, and simply exits the program.
6009 * Warning: do not try to simplify the code for vms. The code
6010 * presupposes that getredirection() is called before any data is
6011 * read from stdin or written to stdout.
6013 * Normal usage is as follows:
6019 * getredirection(&argc, &argv);
6023 int argc = *ac; /* Argument Count */
6024 char **argv = *av; /* Argument Vector */
6025 char *ap; /* Argument pointer */
6026 int j; /* argv[] index */
6027 int item_count = 0; /* Count of Items in List */
6028 struct list_item *list_head = 0; /* First Item in List */
6029 struct list_item *list_tail; /* Last Item in List */
6030 char *in = NULL; /* Input File Name */
6031 char *out = NULL; /* Output File Name */
6032 char *outmode = "w"; /* Mode to Open Output File */
6033 char *err = NULL; /* Error File Name */
6034 char *errmode = "w"; /* Mode to Open Error File */
6035 int cmargc = 0; /* Piped Command Arg Count */
6036 char **cmargv = NULL;/* Piped Command Arg Vector */
6039 * First handle the case where the last thing on the line ends with
6040 * a '&'. This indicates the desire for the command to be run in a
6041 * subprocess, so we satisfy that desire.
6044 if (0 == strcmp("&", ap))
6045 exit(background_process(aTHX_ --argc, argv));
6046 if (*ap && '&' == ap[strlen(ap)-1])
6048 ap[strlen(ap)-1] = '\0';
6049 exit(background_process(aTHX_ argc, argv));
6052 * Now we handle the general redirection cases that involve '>', '>>',
6053 * '<', and pipes '|'.
6055 for (j = 0; j < argc; ++j)
6057 if (0 == strcmp("<", argv[j]))
6061 fprintf(stderr,"No input file after < on command line");
6062 exit(LIB$_WRONUMARG);
6067 if ('<' == *(ap = argv[j]))
6072 if (0 == strcmp(">", ap))
6076 fprintf(stderr,"No output file after > on command line");
6077 exit(LIB$_WRONUMARG);
6096 fprintf(stderr,"No output file after > or >> on command line");
6097 exit(LIB$_WRONUMARG);
6101 if (('2' == *ap) && ('>' == ap[1]))
6118 fprintf(stderr,"No output file after 2> or 2>> on command line");
6119 exit(LIB$_WRONUMARG);
6123 if (0 == strcmp("|", argv[j]))
6127 fprintf(stderr,"No command into which to pipe on command line");
6128 exit(LIB$_WRONUMARG);
6130 cmargc = argc-(j+1);
6131 cmargv = &argv[j+1];
6135 if ('|' == *(ap = argv[j]))
6143 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6146 * Allocate and fill in the new argument vector, Some Unix's terminate
6147 * the list with an extra null pointer.
6149 Newx(argv, item_count+1, char *);
6151 for (j = 0; j < item_count; ++j, list_head = list_head->next)
6152 argv[j] = list_head->value;
6158 fprintf(stderr,"'|' and '>' may not both be specified on command line");
6159 exit(LIB$_INVARGORD);
6161 pipe_and_fork(aTHX_ cmargv);
6164 /* Check for input from a pipe (mailbox) */
6166 if (in == NULL && 1 == isapipe(0))
6168 char mbxname[L_tmpnam];
6170 long int dvi_item = DVI$_DEVBUFSIZ;
6171 $DESCRIPTOR(mbxnam, "");
6172 $DESCRIPTOR(mbxdevnam, "");
6174 /* Input from a pipe, reopen it in binary mode to disable */
6175 /* carriage control processing. */
6177 fgetname(stdin, mbxname);
6178 mbxnam.dsc$a_pointer = mbxname;
6179 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6180 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6181 mbxdevnam.dsc$a_pointer = mbxname;
6182 mbxdevnam.dsc$w_length = sizeof(mbxname);
6183 dvi_item = DVI$_DEVNAM;
6184 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6185 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
6188 freopen(mbxname, "rb", stdin);
6191 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
6195 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6197 fprintf(stderr,"Can't open input file %s as stdin",in);
6200 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
6202 fprintf(stderr,"Can't open output file %s as stdout",out);
6205 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
6208 if (strcmp(err,"&1") == 0) {
6209 dup2(fileno(stdout), fileno(stderr));
6210 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
6213 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
6215 fprintf(stderr,"Can't open error file %s as stderr",err);
6219 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
6223 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
6226 #ifdef ARGPROC_DEBUG
6227 PerlIO_printf(Perl_debug_log, "Arglist:\n");
6228 for (j = 0; j < *ac; ++j)
6229 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
6231 /* Clear errors we may have hit expanding wildcards, so they don't
6232 show up in Perl's $! later */
6233 set_errno(0); set_vaxc_errno(1);
6234 } /* end of getredirection() */
6237 static void add_item(struct list_item **head,
6238 struct list_item **tail,
6244 Newx(*head,1,struct list_item);
6248 Newx((*tail)->next,1,struct list_item);
6249 *tail = (*tail)->next;
6251 (*tail)->value = value;
6255 static void mp_expand_wild_cards(pTHX_ char *item,
6256 struct list_item **head,
6257 struct list_item **tail,
6261 unsigned long int context = 0;
6268 char vmsspec[NAM$C_MAXRSS+1];
6269 $DESCRIPTOR(filespec, "");
6270 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
6271 $DESCRIPTOR(resultspec, "");
6272 unsigned long int zero = 0, sts;
6274 for (cp = item; *cp; cp++) {
6275 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
6276 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
6278 if (!*cp || isspace(*cp))
6280 add_item(head, tail, item, count);
6285 /* "double quoted" wild card expressions pass as is */
6286 /* From DCL that means using e.g.: */
6287 /* perl program """perl.*""" */
6288 item_len = strlen(item);
6289 if ( '"' == *item && '"' == item[item_len-1] )
6292 item[item_len-2] = '\0';
6293 add_item(head, tail, item, count);
6297 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
6298 resultspec.dsc$b_class = DSC$K_CLASS_D;
6299 resultspec.dsc$a_pointer = NULL;
6300 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
6301 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
6302 if (!isunix || !filespec.dsc$a_pointer)
6303 filespec.dsc$a_pointer = item;
6304 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
6306 * Only return version specs, if the caller specified a version
6308 had_version = strchr(item, ';');
6310 * Only return device and directory specs, if the caller specifed either.
6312 had_device = strchr(item, ':');
6313 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
6315 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
6316 &defaultspec, 0, 0, &zero))))
6321 Newx(string,resultspec.dsc$w_length+1,char);
6322 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
6323 string[resultspec.dsc$w_length] = '\0';
6324 if (NULL == had_version)
6325 *(strrchr(string, ';')) = '\0';
6326 if ((!had_directory) && (had_device == NULL))
6328 if (NULL == (devdir = strrchr(string, ']')))
6329 devdir = strrchr(string, '>');
6330 strcpy(string, devdir + 1);
6333 * Be consistent with what the C RTL has already done to the rest of
6334 * the argv items and lowercase all of these names.
6336 if (!decc_efs_case_preserve) {
6337 for (c = string; *c; ++c)
6341 if (isunix) trim_unixpath(string,item,1);
6342 add_item(head, tail, string, count);
6345 if (sts != RMS$_NMF)
6347 set_vaxc_errno(sts);
6350 case RMS$_FNF: case RMS$_DNF:
6351 set_errno(ENOENT); break;
6353 set_errno(ENOTDIR); break;
6355 set_errno(ENODEV); break;
6356 case RMS$_FNM: case RMS$_SYN:
6357 set_errno(EINVAL); break;
6359 set_errno(EACCES); break;
6361 _ckvmssts_noperl(sts);
6365 add_item(head, tail, item, count);
6366 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
6367 _ckvmssts_noperl(lib$find_file_end(&context));
6370 static int child_st[2];/* Event Flag set when child process completes */
6372 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
6374 static unsigned long int exit_handler(int *status)
6378 if (0 == child_st[0])
6380 #ifdef ARGPROC_DEBUG
6381 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
6383 fflush(stdout); /* Have to flush pipe for binary data to */
6384 /* terminate properly -- <tp@mccall.com> */
6385 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
6386 sys$dassgn(child_chan);
6388 sys$synch(0, child_st);
6393 static void sig_child(int chan)
6395 #ifdef ARGPROC_DEBUG
6396 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
6398 if (child_st[0] == 0)
6402 static struct exit_control_block exit_block =
6407 &exit_block.exit_status,
6412 pipe_and_fork(pTHX_ char **cmargv)
6415 struct dsc$descriptor_s *vmscmd;
6416 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
6417 int sts, j, l, ismcr, quote, tquote = 0;
6419 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
6420 vms_execfree(vmscmd);
6425 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
6426 && toupper(*(q+2)) == 'R' && !*(q+3);
6428 while (q && l < MAX_DCL_LINE_LENGTH) {
6430 if (j > 0 && quote) {
6436 if (ismcr && j > 1) quote = 1;
6437 tquote = (strchr(q,' ')) != NULL || *q == '\0';
6440 if (quote || tquote) {
6446 if ((quote||tquote) && *q == '"') {
6456 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
6458 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
6462 static int background_process(pTHX_ int argc, char **argv)
6464 char command[2048] = "$";
6465 $DESCRIPTOR(value, "");
6466 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
6467 static $DESCRIPTOR(null, "NLA0:");
6468 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
6470 $DESCRIPTOR(pidstr, "");
6472 unsigned long int flags = 17, one = 1, retsts;
6474 strcat(command, argv[0]);
6477 strcat(command, " \"");
6478 strcat(command, *(++argv));
6479 strcat(command, "\"");
6481 value.dsc$a_pointer = command;
6482 value.dsc$w_length = strlen(value.dsc$a_pointer);
6483 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
6484 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
6485 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
6486 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
6489 _ckvmssts_noperl(retsts);
6491 #ifdef ARGPROC_DEBUG
6492 PerlIO_printf(Perl_debug_log, "%s\n", command);
6494 sprintf(pidstring, "%08X", pid);
6495 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
6496 pidstr.dsc$a_pointer = pidstring;
6497 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
6498 lib$set_symbol(&pidsymbol, &pidstr);
6502 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
6505 /* OS-specific initialization at image activation (not thread startup) */
6506 /* Older VAXC header files lack these constants */
6507 #ifndef JPI$_RIGHTS_SIZE
6508 # define JPI$_RIGHTS_SIZE 817
6510 #ifndef KGB$M_SUBSYSTEM
6511 # define KGB$M_SUBSYSTEM 0x8
6514 /*{{{void vms_image_init(int *, char ***)*/
6516 vms_image_init(int *argcp, char ***argvp)
6518 char eqv[LNM$C_NAMLENGTH+1] = "";
6519 unsigned int len, tabct = 8, tabidx = 0;
6520 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
6521 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
6522 unsigned short int dummy, rlen;
6523 struct dsc$descriptor_s **tabvec;
6524 #if defined(PERL_IMPLICIT_CONTEXT)
6527 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
6528 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
6529 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
6532 #ifdef KILL_BY_SIGPRC
6533 Perl_csighandler_init();
6536 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
6537 _ckvmssts_noperl(iosb[0]);
6538 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
6539 if (iprv[i]) { /* Running image installed with privs? */
6540 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
6545 /* Rights identifiers might trigger tainting as well. */
6546 if (!will_taint && (rlen || rsz)) {
6547 while (rlen < rsz) {
6548 /* We didn't get all the identifiers on the first pass. Allocate a
6549 * buffer much larger than $GETJPI wants (rsz is size in bytes that
6550 * were needed to hold all identifiers at time of last call; we'll
6551 * allocate that many unsigned long ints), and go back and get 'em.
6552 * If it gave us less than it wanted to despite ample buffer space,
6553 * something's broken. Is your system missing a system identifier?
6555 if (rsz <= jpilist[1].buflen) {
6556 /* Perl_croak accvios when used this early in startup. */
6557 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
6558 rsz, (unsigned long) jpilist[1].buflen,
6559 "Check your rights database for corruption.\n");
6562 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
6563 jpilist[1].bufadr = Newx(mask,rsz,unsigned long int);
6564 jpilist[1].buflen = rsz * sizeof(unsigned long int);
6565 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
6566 _ckvmssts_noperl(iosb[0]);
6568 mask = jpilist[1].bufadr;
6569 /* Check attribute flags for each identifier (2nd longword); protected
6570 * subsystem identifiers trigger tainting.
6572 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
6573 if (mask[i] & KGB$M_SUBSYSTEM) {
6578 if (mask != rlst) Safefree(mask);
6581 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
6582 * logical, some versions of the CRTL will add a phanthom /000000/
6583 * directory. This needs to be removed.
6585 if (decc_filename_unix_report) {
6588 ulen = strlen(argvp[0][0]);
6590 zeros = strstr(argvp[0][0], "/000000/");
6591 if (zeros != NULL) {
6593 mlen = ulen - (zeros - argvp[0][0]) - 7;
6594 memmove(zeros, &zeros[7], mlen);
6596 argvp[0][0][ulen] = '\0';
6599 /* It also may have a trailing dot that needs to be removed otherwise
6600 * it will be converted to VMS mode incorrectly.
6603 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
6604 argvp[0][0][ulen] = '\0';
6607 /* We need to use this hack to tell Perl it should run with tainting,
6608 * since its tainting flag may be part of the PL_curinterp struct, which
6609 * hasn't been allocated when vms_image_init() is called.
6612 char **newargv, **oldargv;
6614 Newx(newargv,(*argcp)+2,char *);
6615 newargv[0] = oldargv[0];
6616 Newx(newargv[1],3,char);
6617 strcpy(newargv[1], "-T");
6618 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
6620 newargv[*argcp] = NULL;
6621 /* We orphan the old argv, since we don't know where it's come from,
6622 * so we don't know how to free it.
6626 else { /* Did user explicitly request tainting? */
6628 char *cp, **av = *argvp;
6629 for (i = 1; i < *argcp; i++) {
6630 if (*av[i] != '-') break;
6631 for (cp = av[i]+1; *cp; cp++) {
6632 if (*cp == 'T') { will_taint = 1; break; }
6633 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
6634 strchr("DFIiMmx",*cp)) break;
6636 if (will_taint) break;
6641 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
6643 if (!tabidx) Newx(tabvec,tabct,struct dsc$descriptor_s *);
6644 else if (tabidx >= tabct) {
6646 Renew(tabvec,tabct,struct dsc$descriptor_s *);
6648 Newx(tabvec[tabidx],1,struct dsc$descriptor_s);
6649 tabvec[tabidx]->dsc$w_length = 0;
6650 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
6651 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
6652 tabvec[tabidx]->dsc$a_pointer = NULL;
6653 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
6655 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
6657 getredirection(argcp,argvp);
6658 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
6660 # include <reentrancy.h>
6661 decc$set_reentrancy(C$C_MULTITHREAD);
6670 * Trim Unix-style prefix off filespec, so it looks like what a shell
6671 * glob expansion would return (i.e. from specified prefix on, not
6672 * full path). Note that returned filespec is Unix-style, regardless
6673 * of whether input filespec was VMS-style or Unix-style.
6675 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
6676 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
6677 * vector of options; at present, only bit 0 is used, and if set tells
6678 * trim unixpath to try the current default directory as a prefix when
6679 * presented with a possibly ambiguous ... wildcard.
6681 * Returns !=0 on success, with trimmed filespec replacing contents of
6682 * fspec, and 0 on failure, with contents of fpsec unchanged.
6684 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
6686 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
6688 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
6689 *template, *base, *end, *cp1, *cp2;
6690 register int tmplen, reslen = 0, dirs = 0;
6692 if (!wildspec || !fspec) return 0;
6693 template = unixwild;
6694 if (strpbrk(wildspec,"]>:") != NULL) {
6695 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
6698 strncpy(unixwild, wildspec, NAM$C_MAXRSS);
6699 unixwild[NAM$C_MAXRSS] = 0;
6701 if (strpbrk(fspec,"]>:") != NULL) {
6702 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
6703 else base = unixified;
6704 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
6705 * check to see that final result fits into (isn't longer than) fspec */
6706 reslen = strlen(fspec);
6710 /* No prefix or absolute path on wildcard, so nothing to remove */
6711 if (!*template || *template == '/') {
6712 if (base == fspec) return 1;
6713 tmplen = strlen(unixified);
6714 if (tmplen > reslen) return 0; /* not enough space */
6715 /* Copy unixified resultant, including trailing NUL */
6716 memmove(fspec,unixified,tmplen+1);
6720 for (end = base; *end; end++) ; /* Find end of resultant filespec */
6721 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
6722 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
6723 for (cp1 = end ;cp1 >= base; cp1--)
6724 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
6726 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
6730 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
6731 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
6732 int ells = 1, totells, segdirs, match;
6733 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
6734 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6736 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
6738 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
6739 if (ellipsis == template && opts & 1) {
6740 /* Template begins with an ellipsis. Since we can't tell how many
6741 * directory names at the front of the resultant to keep for an
6742 * arbitrary starting point, we arbitrarily choose the current
6743 * default directory as a starting point. If it's there as a prefix,
6744 * clip it off. If not, fall through and act as if the leading
6745 * ellipsis weren't there (i.e. return shortest possible path that
6746 * could match template).
6748 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
6749 if (!decc_efs_case_preserve) {
6750 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
6751 if (_tolower(*cp1) != _tolower(*cp2)) break;
6753 segdirs = dirs - totells; /* Min # of dirs we must have left */
6754 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
6755 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
6756 memcpy(fspec,cp2+1,end - cp2);
6760 /* First off, back up over constant elements at end of path */
6762 for (front = end ; front >= base; front--)
6763 if (*front == '/' && !dirs--) { front++; break; }
6765 if (!decc_efs_case_preserve) {
6766 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
6767 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
6769 if (cp1 != '\0') return 0; /* Path too long. */
6771 *cp2 = '\0'; /* Pick up with memcpy later */
6772 lcfront = lcres + (front - base);
6773 /* Now skip over each ellipsis and try to match the path in front of it. */
6775 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
6776 if (*(cp1) == '.' && *(cp1+1) == '.' &&
6777 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
6778 if (cp1 < template) break; /* template started with an ellipsis */
6779 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
6780 ellipsis = cp1; continue;
6782 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
6784 for (segdirs = 0, cp2 = tpl;
6785 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
6787 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
6789 if (!decc_efs_case_preserve) {
6790 *cp2 = _tolower(*cp1); /* else lowercase for match */
6793 *cp2 = *cp1; /* else preserve case for match */
6796 if (*cp2 == '/') segdirs++;
6798 if (cp1 != ellipsis - 1) return 0; /* Path too long */
6799 /* Back up at least as many dirs as in template before matching */
6800 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
6801 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
6802 for (match = 0; cp1 > lcres;) {
6803 resdsc.dsc$a_pointer = cp1;
6804 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
6806 if (match == 1) lcfront = cp1;
6808 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
6810 if (!match) return 0; /* Can't find prefix ??? */
6811 if (match > 1 && opts & 1) {
6812 /* This ... wildcard could cover more than one set of dirs (i.e.
6813 * a set of similar dir names is repeated). If the template
6814 * contains more than 1 ..., upstream elements could resolve the
6815 * ambiguity, but it's not worth a full backtracking setup here.
6816 * As a quick heuristic, clip off the current default directory
6817 * if it's present to find the trimmed spec, else use the
6818 * shortest string that this ... could cover.
6820 char def[NAM$C_MAXRSS+1], *st;
6822 if (getcwd(def, sizeof def,0) == NULL) return 0;
6823 if (!decc_efs_case_preserve) {
6824 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
6825 if (_tolower(*cp1) != _tolower(*cp2)) break;
6827 segdirs = dirs - totells; /* Min # of dirs we must have left */
6828 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
6829 if (*cp1 == '\0' && *cp2 == '/') {
6830 memcpy(fspec,cp2+1,end - cp2);
6833 /* Nope -- stick with lcfront from above and keep going. */
6836 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
6841 } /* end of trim_unixpath() */
6846 * VMS readdir() routines.
6847 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
6849 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
6850 * Minor modifications to original routines.
6853 /* readdir may have been redefined by reentr.h, so make sure we get
6854 * the local version for what we do here.
6859 #if !defined(PERL_IMPLICIT_CONTEXT)
6860 # define readdir Perl_readdir
6862 # define readdir(a) Perl_readdir(aTHX_ a)
6865 /* Number of elements in vms_versions array */
6866 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
6869 * Open a directory, return a handle for later use.
6871 /*{{{ DIR *opendir(char*name) */
6873 Perl_opendir(pTHX_ const char *name)
6876 char dir[NAM$C_MAXRSS+1];
6879 if (do_tovmspath(name,dir,0) == NULL) {
6882 /* Check access before stat; otherwise stat does not
6883 * accurately report whether it's a directory.
6885 if (!cando_by_name(S_IRUSR,0,dir)) {
6886 /* cando_by_name has already set errno */
6889 if (flex_stat(dir,&sb) == -1) return NULL;
6890 if (!S_ISDIR(sb.st_mode)) {
6891 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
6894 /* Get memory for the handle, and the pattern. */
6896 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
6898 /* Fill in the fields; mainly playing with the descriptor. */
6899 sprintf(dd->pattern, "%s*.*",dir);
6902 dd->vms_wantversions = 0;
6903 dd->pat.dsc$a_pointer = dd->pattern;
6904 dd->pat.dsc$w_length = strlen(dd->pattern);
6905 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
6906 dd->pat.dsc$b_class = DSC$K_CLASS_S;
6907 #if defined(USE_ITHREADS)
6908 Newx(dd->mutex,1,perl_mutex);
6909 MUTEX_INIT( (perl_mutex *) dd->mutex );
6915 } /* end of opendir() */
6919 * Set the flag to indicate we want versions or not.
6921 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
6923 vmsreaddirversions(MY_DIR *dd, int flag)
6925 dd->vms_wantversions = flag;
6930 * Free up an opened directory.
6932 /*{{{ void closedir(DIR *dd)*/
6934 Perl_closedir(MY_DIR *dd)
6938 sts = lib$find_file_end(&dd->context);
6939 Safefree(dd->pattern);
6940 #if defined(USE_ITHREADS)
6941 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
6942 Safefree(dd->mutex);
6949 * Collect all the version numbers for the current file.
6952 collectversions(pTHX_ MY_DIR *dd)
6954 struct dsc$descriptor_s pat;
6955 struct dsc$descriptor_s res;
6956 struct my_dirent *e;
6957 char *p, *text, buff[sizeof dd->entry.d_name];
6959 unsigned long context, tmpsts;
6961 /* Convenient shorthand. */
6964 /* Add the version wildcard, ignoring the "*.*" put on before */
6965 i = strlen(dd->pattern);
6966 Newx(text,i + e->d_namlen + 3,char);
6967 strcpy(text, dd->pattern);
6968 sprintf(&text[i - 3], "%s;*", e->d_name);
6970 /* Set up the pattern descriptor. */
6971 pat.dsc$a_pointer = text;
6972 pat.dsc$w_length = i + e->d_namlen - 1;
6973 pat.dsc$b_dtype = DSC$K_DTYPE_T;
6974 pat.dsc$b_class = DSC$K_CLASS_S;
6976 /* Set up result descriptor. */
6977 res.dsc$a_pointer = buff;
6978 res.dsc$w_length = sizeof buff - 2;
6979 res.dsc$b_dtype = DSC$K_DTYPE_T;
6980 res.dsc$b_class = DSC$K_CLASS_S;
6982 /* Read files, collecting versions. */
6983 for (context = 0, e->vms_verscount = 0;
6984 e->vms_verscount < VERSIZE(e);
6985 e->vms_verscount++) {
6986 tmpsts = lib$find_file(&pat, &res, &context);
6987 if (tmpsts == RMS$_NMF || context == 0) break;
6989 buff[sizeof buff - 1] = '\0';
6990 if ((p = strchr(buff, ';')))
6991 e->vms_versions[e->vms_verscount] = atoi(p + 1);
6993 e->vms_versions[e->vms_verscount] = -1;
6996 _ckvmssts(lib$find_file_end(&context));
6999 } /* end of collectversions() */
7002 * Read the next entry from the directory.
7004 /*{{{ struct dirent *readdir(DIR *dd)*/
7006 Perl_readdir(pTHX_ MY_DIR *dd)
7008 struct dsc$descriptor_s res;
7009 char *p, buff[sizeof dd->entry.d_name];
7010 unsigned long int tmpsts;
7012 /* Set up result descriptor, and get next file. */
7013 res.dsc$a_pointer = buff;
7014 res.dsc$w_length = sizeof buff - 2;
7015 res.dsc$b_dtype = DSC$K_DTYPE_T;
7016 res.dsc$b_class = DSC$K_CLASS_S;
7017 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
7018 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
7019 if (!(tmpsts & 1)) {
7020 set_vaxc_errno(tmpsts);
7023 set_errno(EACCES); break;
7025 set_errno(ENODEV); break;
7027 set_errno(ENOTDIR); break;
7028 case RMS$_FNF: case RMS$_DNF:
7029 set_errno(ENOENT); break;
7036 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
7037 if (!decc_efs_case_preserve) {
7038 buff[sizeof buff - 1] = '\0';
7039 for (p = buff; *p; p++) *p = _tolower(*p);
7040 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7044 /* we don't want to force to lowercase, just null terminate */
7045 buff[res.dsc$w_length] = '\0';
7047 for (p = buff; *p; p++) *p = _tolower(*p);
7048 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7051 /* Skip any directory component and just copy the name. */
7052 if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1);
7053 else strcpy(dd->entry.d_name, buff);
7055 /* Clobber the version. */
7056 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
7058 dd->entry.d_namlen = strlen(dd->entry.d_name);
7059 dd->entry.vms_verscount = 0;
7060 if (dd->vms_wantversions) collectversions(aTHX_ dd);
7063 } /* end of readdir() */
7067 * Read the next entry from the directory -- thread-safe version.
7069 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
7071 Perl_readdir_r(pTHX_ MY_DIR *dd, struct my_dirent *entry, struct my_dirent **result)
7075 MUTEX_LOCK( (perl_mutex *) dd->mutex );
7077 entry = Perl_readdir(dd);
7079 retval = ( *result == NULL ? errno : 0 );
7081 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
7085 } /* end of readdir_r() */
7089 * Return something that can be used in a seekdir later.
7091 /*{{{ long telldir(DIR *dd)*/
7093 Perl_telldir(MY_DIR *dd)
7100 * Return to a spot where we used to be. Brute force.
7102 /*{{{ void seekdir(DIR *dd,long count)*/
7104 Perl_seekdir(pTHX_ MY_DIR *dd, long count)
7106 int vms_wantversions;
7108 /* If we haven't done anything yet... */
7112 /* Remember some state, and clear it. */
7113 vms_wantversions = dd->vms_wantversions;
7114 dd->vms_wantversions = 0;
7115 _ckvmssts(lib$find_file_end(&dd->context));
7118 /* The increment is in readdir(). */
7119 for (dd->count = 0; dd->count < count; )
7122 dd->vms_wantversions = vms_wantversions;
7124 } /* end of seekdir() */
7127 /* VMS subprocess management
7129 * my_vfork() - just a vfork(), after setting a flag to record that
7130 * the current script is trying a Unix-style fork/exec.
7132 * vms_do_aexec() and vms_do_exec() are called in response to the
7133 * perl 'exec' function. If this follows a vfork call, then they
7134 * call out the regular perl routines in doio.c which do an
7135 * execvp (for those who really want to try this under VMS).
7136 * Otherwise, they do exactly what the perl docs say exec should
7137 * do - terminate the current script and invoke a new command
7138 * (See below for notes on command syntax.)
7140 * do_aspawn() and do_spawn() implement the VMS side of the perl
7141 * 'system' function.
7143 * Note on command arguments to perl 'exec' and 'system': When handled
7144 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
7145 * are concatenated to form a DCL command string. If the first arg
7146 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
7147 * the command string is handed off to DCL directly. Otherwise,
7148 * the first token of the command is taken as the filespec of an image
7149 * to run. The filespec is expanded using a default type of '.EXE' and
7150 * the process defaults for device, directory, etc., and if found, the resultant
7151 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
7152 * the command string as parameters. This is perhaps a bit complicated,
7153 * but I hope it will form a happy medium between what VMS folks expect
7154 * from lib$spawn and what Unix folks expect from exec.
7157 static int vfork_called;
7159 /*{{{int my_vfork()*/
7170 vms_execfree(struct dsc$descriptor_s *vmscmd)
7173 if (vmscmd->dsc$a_pointer) {
7174 Safefree(vmscmd->dsc$a_pointer);
7181 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
7183 char *junk, *tmps = Nullch;
7184 register size_t cmdlen = 0;
7191 tmps = SvPV(really,rlen);
7198 for (idx++; idx <= sp; idx++) {
7200 junk = SvPVx(*idx,rlen);
7201 cmdlen += rlen ? rlen + 1 : 0;
7204 Newx(PL_Cmd,cmdlen+1,char);
7206 if (tmps && *tmps) {
7207 strcpy(PL_Cmd,tmps);
7210 else *PL_Cmd = '\0';
7211 while (++mark <= sp) {
7213 char *s = SvPVx(*mark,n_a);
7215 if (*PL_Cmd) strcat(PL_Cmd," ");
7221 } /* end of setup_argstr() */
7224 static unsigned long int
7225 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
7226 struct dsc$descriptor_s **pvmscmd)
7228 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
7229 char image_name[NAM$C_MAXRSS+1];
7230 char image_argv[NAM$C_MAXRSS+1];
7231 $DESCRIPTOR(defdsc,".EXE");
7232 $DESCRIPTOR(defdsc2,".");
7233 $DESCRIPTOR(resdsc,resspec);
7234 struct dsc$descriptor_s *vmscmd;
7235 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7236 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
7237 register char *s, *rest, *cp, *wordbreak;
7242 Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
7244 /* Make a copy for modification */
7245 cmdlen = strlen(incmd);
7246 Newx(cmd, cmdlen+1, char);
7247 strncpy(cmd, incmd, cmdlen);
7252 vmscmd->dsc$a_pointer = NULL;
7253 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
7254 vmscmd->dsc$b_class = DSC$K_CLASS_S;
7255 vmscmd->dsc$w_length = 0;
7256 if (pvmscmd) *pvmscmd = vmscmd;
7258 if (suggest_quote) *suggest_quote = 0;
7260 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
7261 return CLI$_BUFOVF; /* continuation lines currently unsupported */
7267 while (*s && isspace(*s)) s++;
7269 if (*s == '@' || *s == '$') {
7270 vmsspec[0] = *s; rest = s + 1;
7271 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
7273 else { cp = vmsspec; rest = s; }
7274 if (*rest == '.' || *rest == '/') {
7277 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
7278 rest++, cp2++) *cp2 = *rest;
7280 if (do_tovmsspec(resspec,cp,0)) {
7283 for (cp2 = vmsspec + strlen(vmsspec);
7284 *rest && cp2 - vmsspec < sizeof vmsspec;
7285 rest++, cp2++) *cp2 = *rest;
7290 /* Intuit whether verb (first word of cmd) is a DCL command:
7291 * - if first nonspace char is '@', it's a DCL indirection
7293 * - if verb contains a filespec separator, it's not a DCL command
7294 * - if it doesn't, caller tells us whether to default to a DCL
7295 * command, or to a local image unless told it's DCL (by leading '$')
7299 if (suggest_quote) *suggest_quote = 1;
7301 register char *filespec = strpbrk(s,":<[.;");
7302 rest = wordbreak = strpbrk(s," \"\t/");
7303 if (!wordbreak) wordbreak = s + strlen(s);
7304 if (*s == '$') check_img = 0;
7305 if (filespec && (filespec < wordbreak)) isdcl = 0;
7306 else isdcl = !check_img;
7310 imgdsc.dsc$a_pointer = s;
7311 imgdsc.dsc$w_length = wordbreak - s;
7312 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7314 _ckvmssts(lib$find_file_end(&cxt));
7315 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7316 if (!(retsts & 1) && *s == '$') {
7317 _ckvmssts(lib$find_file_end(&cxt));
7318 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
7319 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7321 _ckvmssts(lib$find_file_end(&cxt));
7322 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7326 _ckvmssts(lib$find_file_end(&cxt));
7331 while (*s && !isspace(*s)) s++;
7334 /* check that it's really not DCL with no file extension */
7335 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
7337 char b[256] = {0,0,0,0};
7338 read(fileno(fp), b, 256);
7339 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
7343 /* Check for script */
7345 if ((b[0] == '#') && (b[1] == '!'))
7347 #ifdef ALTERNATE_SHEBANG
7349 shebang_len = strlen(ALTERNATE_SHEBANG);
7350 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
7352 perlstr = strstr("perl",b);
7353 if (perlstr == NULL)
7361 if (shebang_len > 0) {
7364 char tmpspec[NAM$C_MAXRSS + 1];
7367 /* Image is following after white space */
7368 /*--------------------------------------*/
7369 while (isprint(b[i]) && isspace(b[i]))
7373 while (isprint(b[i]) && !isspace(b[i])) {
7374 tmpspec[j++] = b[i++];
7375 if (j >= NAM$C_MAXRSS)
7380 /* There may be some default parameters to the image */
7381 /*---------------------------------------------------*/
7383 while (isprint(b[i])) {
7384 image_argv[j++] = b[i++];
7385 if (j >= NAM$C_MAXRSS)
7388 while ((j > 0) && !isprint(image_argv[j-1]))
7392 /* It will need to be converted to VMS format and validated */
7393 if (tmpspec[0] != '\0') {
7396 /* Try to find the exact program requested to be run */
7397 /*---------------------------------------------------*/
7398 iname = do_rmsexpand
7399 (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
7400 if (iname != NULL) {
7401 if (cando_by_name(S_IXUSR,0,image_name)) {
7402 /* MCR prefix needed */
7406 /* Try again with a null type */
7407 /*----------------------------*/
7408 iname = do_rmsexpand
7409 (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
7410 if (iname != NULL) {
7411 if (cando_by_name(S_IXUSR,0,image_name)) {
7412 /* MCR prefix needed */
7418 /* Did we find the image to run the script? */
7419 /*------------------------------------------*/
7423 /* Assume DCL or foreign command exists */
7424 /*--------------------------------------*/
7425 tchr = strrchr(tmpspec, '/');
7432 strcpy(image_name, tchr);
7440 if (check_img && isdcl) return RMS$_FNF;
7442 if (cando_by_name(S_IXUSR,0,resspec)) {
7443 Newx(vmscmd->dsc$a_pointer, MAX_DCL_LINE_LENGTH ,char);
7445 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
7446 if (image_name[0] != 0) {
7447 strcat(vmscmd->dsc$a_pointer, image_name);
7448 strcat(vmscmd->dsc$a_pointer, " ");
7450 } else if (image_name[0] != 0) {
7451 strcpy(vmscmd->dsc$a_pointer, image_name);
7452 strcat(vmscmd->dsc$a_pointer, " ");
7454 strcpy(vmscmd->dsc$a_pointer,"@");
7456 if (suggest_quote) *suggest_quote = 1;
7458 /* If there is an image name, use original command */
7459 if (image_name[0] == 0)
7460 strcat(vmscmd->dsc$a_pointer,resspec);
7463 while (*rest && isspace(*rest)) rest++;
7466 if (image_argv[0] != 0) {
7467 strcat(vmscmd->dsc$a_pointer,image_argv);
7468 strcat(vmscmd->dsc$a_pointer, " ");
7474 rest_len = strlen(rest);
7475 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
7476 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
7477 strcat(vmscmd->dsc$a_pointer,rest);
7479 retsts = CLI$_BUFOVF;
7481 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
7483 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
7485 else retsts = RMS$_PRV;
7488 /* It's either a DCL command or we couldn't find a suitable image */
7489 vmscmd->dsc$w_length = strlen(cmd);
7490 /* if (cmd == PL_Cmd) {
7491 vmscmd->dsc$a_pointer = PL_Cmd;
7492 if (suggest_quote) *suggest_quote = 1;
7495 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
7499 /* check if it's a symbol (for quoting purposes) */
7500 if (suggest_quote && !*suggest_quote) {
7502 char equiv[LNM$C_NAMLENGTH];
7503 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7504 eqvdsc.dsc$a_pointer = equiv;
7506 iss = lib$get_symbol(vmscmd,&eqvdsc);
7507 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
7509 if (!(retsts & 1)) {
7510 /* just hand off status values likely to be due to user error */
7511 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
7512 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
7513 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
7514 else { _ckvmssts(retsts); }
7517 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
7519 } /* end of setup_cmddsc() */
7522 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
7524 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
7527 if (vfork_called) { /* this follows a vfork - act Unixish */
7529 if (vfork_called < 0) {
7530 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
7533 else return do_aexec(really,mark,sp);
7535 /* no vfork - act VMSish */
7536 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
7541 } /* end of vms_do_aexec() */
7544 /* {{{bool vms_do_exec(char *cmd) */
7546 Perl_vms_do_exec(pTHX_ const char *cmd)
7548 struct dsc$descriptor_s *vmscmd;
7550 if (vfork_called) { /* this follows a vfork - act Unixish */
7552 if (vfork_called < 0) {
7553 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
7556 else return do_exec(cmd);
7559 { /* no vfork - act VMSish */
7560 unsigned long int retsts;
7563 TAINT_PROPER("exec");
7564 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
7565 retsts = lib$do_command(vmscmd);
7568 case RMS$_FNF: case RMS$_DNF:
7569 set_errno(ENOENT); break;
7571 set_errno(ENOTDIR); break;
7573 set_errno(ENODEV); break;
7575 set_errno(EACCES); break;
7577 set_errno(EINVAL); break;
7578 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
7579 set_errno(E2BIG); break;
7580 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
7581 _ckvmssts(retsts); /* fall through */
7582 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
7585 set_vaxc_errno(retsts);
7586 if (ckWARN(WARN_EXEC)) {
7587 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
7588 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
7590 vms_execfree(vmscmd);
7595 } /* end of vms_do_exec() */
7598 unsigned long int Perl_do_spawn(pTHX_ const char *);
7600 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
7602 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
7604 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
7607 } /* end of do_aspawn() */
7610 /* {{{unsigned long int do_spawn(char *cmd) */
7612 Perl_do_spawn(pTHX_ const char *cmd)
7614 unsigned long int sts, substs;
7617 TAINT_PROPER("spawn");
7618 if (!cmd || !*cmd) {
7619 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
7622 case RMS$_FNF: case RMS$_DNF:
7623 set_errno(ENOENT); break;
7625 set_errno(ENOTDIR); break;
7627 set_errno(ENODEV); break;
7629 set_errno(EACCES); break;
7631 set_errno(EINVAL); break;
7632 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
7633 set_errno(E2BIG); break;
7634 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
7635 _ckvmssts(sts); /* fall through */
7636 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
7639 set_vaxc_errno(sts);
7640 if (ckWARN(WARN_EXEC)) {
7641 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
7649 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
7654 } /* end of do_spawn() */
7658 static unsigned int *sockflags, sockflagsize;
7661 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
7662 * routines found in some versions of the CRTL can't deal with sockets.
7663 * We don't shim the other file open routines since a socket isn't
7664 * likely to be opened by a name.
7666 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
7667 FILE *my_fdopen(int fd, const char *mode)
7669 FILE *fp = fdopen(fd, mode);
7672 unsigned int fdoff = fd / sizeof(unsigned int);
7673 Stat_t sbuf; /* native stat; we don't need flex_stat */
7674 if (!sockflagsize || fdoff > sockflagsize) {
7675 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
7676 else Newx (sockflags,fdoff+2,unsigned int);
7677 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
7678 sockflagsize = fdoff + 2;
7680 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
7681 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
7690 * Clear the corresponding bit when the (possibly) socket stream is closed.
7691 * There still a small hole: we miss an implicit close which might occur
7692 * via freopen(). >> Todo
7694 /*{{{ int my_fclose(FILE *fp)*/
7695 int my_fclose(FILE *fp) {
7697 unsigned int fd = fileno(fp);
7698 unsigned int fdoff = fd / sizeof(unsigned int);
7700 if (sockflagsize && fdoff <= sockflagsize)
7701 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
7709 * A simple fwrite replacement which outputs itmsz*nitm chars without
7710 * introducing record boundaries every itmsz chars.
7711 * We are using fputs, which depends on a terminating null. We may
7712 * well be writing binary data, so we need to accommodate not only
7713 * data with nulls sprinkled in the middle but also data with no null
7716 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
7718 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
7720 register char *cp, *end, *cpd, *data;
7721 register unsigned int fd = fileno(dest);
7722 register unsigned int fdoff = fd / sizeof(unsigned int);
7724 int bufsize = itmsz * nitm + 1;
7726 if (fdoff < sockflagsize &&
7727 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
7728 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
7732 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
7733 memcpy( data, src, itmsz*nitm );
7734 data[itmsz*nitm] = '\0';
7736 end = data + itmsz * nitm;
7737 retval = (int) nitm; /* on success return # items written */
7740 while (cpd <= end) {
7741 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
7742 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
7744 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
7748 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
7751 } /* end of my_fwrite() */
7754 /*{{{ int my_flush(FILE *fp)*/
7756 Perl_my_flush(pTHX_ FILE *fp)
7759 if ((res = fflush(fp)) == 0 && fp) {
7760 #ifdef VMS_DO_SOCKETS
7762 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
7764 res = fsync(fileno(fp));
7767 * If the flush succeeded but set end-of-file, we need to clear
7768 * the error because our caller may check ferror(). BTW, this
7769 * probably means we just flushed an empty file.
7771 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
7778 * Here are replacements for the following Unix routines in the VMS environment:
7779 * getpwuid Get information for a particular UIC or UID
7780 * getpwnam Get information for a named user
7781 * getpwent Get information for each user in the rights database
7782 * setpwent Reset search to the start of the rights database
7783 * endpwent Finish searching for users in the rights database
7785 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
7786 * (defined in pwd.h), which contains the following fields:-
7788 * char *pw_name; Username (in lower case)
7789 * char *pw_passwd; Hashed password
7790 * unsigned int pw_uid; UIC
7791 * unsigned int pw_gid; UIC group number
7792 * char *pw_unixdir; Default device/directory (VMS-style)
7793 * char *pw_gecos; Owner name
7794 * char *pw_dir; Default device/directory (Unix-style)
7795 * char *pw_shell; Default CLI name (eg. DCL)
7797 * If the specified user does not exist, getpwuid and getpwnam return NULL.
7799 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
7800 * not the UIC member number (eg. what's returned by getuid()),
7801 * getpwuid() can accept either as input (if uid is specified, the caller's
7802 * UIC group is used), though it won't recognise gid=0.
7804 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
7805 * information about other users in your group or in other groups, respectively.
7806 * If the required privilege is not available, then these routines fill only
7807 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
7810 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
7813 /* sizes of various UAF record fields */
7814 #define UAI$S_USERNAME 12
7815 #define UAI$S_IDENT 31
7816 #define UAI$S_OWNER 31
7817 #define UAI$S_DEFDEV 31
7818 #define UAI$S_DEFDIR 63
7819 #define UAI$S_DEFCLI 31
7822 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
7823 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
7824 (uic).uic$v_group != UIC$K_WILD_GROUP)
7826 static char __empty[]= "";
7827 static struct passwd __passwd_empty=
7828 {(char *) __empty, (char *) __empty, 0, 0,
7829 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
7830 static int contxt= 0;
7831 static struct passwd __pwdcache;
7832 static char __pw_namecache[UAI$S_IDENT+1];
7835 * This routine does most of the work extracting the user information.
7837 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
7840 unsigned char length;
7841 char pw_gecos[UAI$S_OWNER+1];
7843 static union uicdef uic;
7845 unsigned char length;
7846 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
7849 unsigned char length;
7850 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
7853 unsigned char length;
7854 char pw_shell[UAI$S_DEFCLI+1];
7856 static char pw_passwd[UAI$S_PWD+1];
7858 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
7859 struct dsc$descriptor_s name_desc;
7860 unsigned long int sts;
7862 static struct itmlst_3 itmlst[]= {
7863 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
7864 {sizeof(uic), UAI$_UIC, &uic, &luic},
7865 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
7866 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
7867 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
7868 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
7869 {0, 0, NULL, NULL}};
7871 name_desc.dsc$w_length= strlen(name);
7872 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
7873 name_desc.dsc$b_class= DSC$K_CLASS_S;
7874 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
7876 /* Note that sys$getuai returns many fields as counted strings. */
7877 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
7878 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
7879 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
7881 else { _ckvmssts(sts); }
7882 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
7884 if ((int) owner.length < lowner) lowner= (int) owner.length;
7885 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
7886 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
7887 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
7888 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
7889 owner.pw_gecos[lowner]= '\0';
7890 defdev.pw_dir[ldefdev+ldefdir]= '\0';
7891 defcli.pw_shell[ldefcli]= '\0';
7892 if (valid_uic(uic)) {
7893 pwd->pw_uid= uic.uic$l_uic;
7894 pwd->pw_gid= uic.uic$v_group;
7897 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
7898 pwd->pw_passwd= pw_passwd;
7899 pwd->pw_gecos= owner.pw_gecos;
7900 pwd->pw_dir= defdev.pw_dir;
7901 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
7902 pwd->pw_shell= defcli.pw_shell;
7903 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
7905 ldir= strlen(pwd->pw_unixdir) - 1;
7906 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
7909 strcpy(pwd->pw_unixdir, pwd->pw_dir);
7910 if (!decc_efs_case_preserve)
7911 __mystrtolower(pwd->pw_unixdir);
7916 * Get information for a named user.
7918 /*{{{struct passwd *getpwnam(char *name)*/
7919 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
7921 struct dsc$descriptor_s name_desc;
7923 unsigned long int status, sts;
7925 __pwdcache = __passwd_empty;
7926 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
7927 /* We still may be able to determine pw_uid and pw_gid */
7928 name_desc.dsc$w_length= strlen(name);
7929 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
7930 name_desc.dsc$b_class= DSC$K_CLASS_S;
7931 name_desc.dsc$a_pointer= (char *) name;
7932 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
7933 __pwdcache.pw_uid= uic.uic$l_uic;
7934 __pwdcache.pw_gid= uic.uic$v_group;
7937 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
7938 set_vaxc_errno(sts);
7939 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
7942 else { _ckvmssts(sts); }
7945 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
7946 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
7947 __pwdcache.pw_name= __pw_namecache;
7949 } /* end of my_getpwnam() */
7953 * Get information for a particular UIC or UID.
7954 * Called by my_getpwent with uid=-1 to list all users.
7956 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
7957 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
7959 const $DESCRIPTOR(name_desc,__pw_namecache);
7960 unsigned short lname;
7962 unsigned long int status;
7964 if (uid == (unsigned int) -1) {
7966 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
7967 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
7968 set_vaxc_errno(status);
7969 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
7973 else { _ckvmssts(status); }
7974 } while (!valid_uic (uic));
7978 if (!uic.uic$v_group)
7979 uic.uic$v_group= PerlProc_getgid();
7981 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
7982 else status = SS$_IVIDENT;
7983 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
7984 status == RMS$_PRV) {
7985 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
7988 else { _ckvmssts(status); }
7990 __pw_namecache[lname]= '\0';
7991 __mystrtolower(__pw_namecache);
7993 __pwdcache = __passwd_empty;
7994 __pwdcache.pw_name = __pw_namecache;
7996 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
7997 The identifier's value is usually the UIC, but it doesn't have to be,
7998 so if we can, we let fillpasswd update this. */
7999 __pwdcache.pw_uid = uic.uic$l_uic;
8000 __pwdcache.pw_gid = uic.uic$v_group;
8002 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
8005 } /* end of my_getpwuid() */
8009 * Get information for next user.
8011 /*{{{struct passwd *my_getpwent()*/
8012 struct passwd *Perl_my_getpwent(pTHX)
8014 return (my_getpwuid((unsigned int) -1));
8019 * Finish searching rights database for users.
8021 /*{{{void my_endpwent()*/
8022 void Perl_my_endpwent(pTHX)
8025 _ckvmssts(sys$finish_rdb(&contxt));
8031 #ifdef HOMEGROWN_POSIX_SIGNALS
8032 /* Signal handling routines, pulled into the core from POSIX.xs.
8034 * We need these for threads, so they've been rolled into the core,
8035 * rather than left in POSIX.xs.
8037 * (DRS, Oct 23, 1997)
8040 /* sigset_t is atomic under VMS, so these routines are easy */
8041 /*{{{int my_sigemptyset(sigset_t *) */
8042 int my_sigemptyset(sigset_t *set) {
8043 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8049 /*{{{int my_sigfillset(sigset_t *)*/
8050 int my_sigfillset(sigset_t *set) {
8052 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8053 for (i = 0; i < NSIG; i++) *set |= (1 << i);
8059 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
8060 int my_sigaddset(sigset_t *set, int sig) {
8061 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8062 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8063 *set |= (1 << (sig - 1));
8069 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
8070 int my_sigdelset(sigset_t *set, int sig) {
8071 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8072 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8073 *set &= ~(1 << (sig - 1));
8079 /*{{{int my_sigismember(sigset_t *set, int sig)*/
8080 int my_sigismember(sigset_t *set, int sig) {
8081 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8082 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8083 return *set & (1 << (sig - 1));
8088 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
8089 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
8092 /* If set and oset are both null, then things are badly wrong. Bail out. */
8093 if ((oset == NULL) && (set == NULL)) {
8094 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
8098 /* If set's null, then we're just handling a fetch. */
8100 tempmask = sigblock(0);
8105 tempmask = sigsetmask(*set);
8108 tempmask = sigblock(*set);
8111 tempmask = sigblock(0);
8112 sigsetmask(*oset & ~tempmask);
8115 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8120 /* Did they pass us an oset? If so, stick our holding mask into it */
8127 #endif /* HOMEGROWN_POSIX_SIGNALS */
8130 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
8131 * my_utime(), and flex_stat(), all of which operate on UTC unless
8132 * VMSISH_TIMES is true.
8134 /* method used to handle UTC conversions:
8135 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
8137 static int gmtime_emulation_type;
8138 /* number of secs to add to UTC POSIX-style time to get local time */
8139 static long int utc_offset_secs;
8141 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
8142 * in vmsish.h. #undef them here so we can call the CRTL routines
8151 * DEC C previous to 6.0 corrupts the behavior of the /prefix
8152 * qualifier with the extern prefix pragma. This provisional
8153 * hack circumvents this prefix pragma problem in previous
8156 #if defined(__VMS_VER) && __VMS_VER >= 70000000
8157 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
8158 # pragma __extern_prefix save
8159 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
8160 # define gmtime decc$__utctz_gmtime
8161 # define localtime decc$__utctz_localtime
8162 # define time decc$__utc_time
8163 # pragma __extern_prefix restore
8165 struct tm *gmtime(), *localtime();
8171 static time_t toutc_dst(time_t loc) {
8174 if ((rsltmp = localtime(&loc)) == NULL) return -1;
8175 loc -= utc_offset_secs;
8176 if (rsltmp->tm_isdst) loc -= 3600;
8179 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
8180 ((gmtime_emulation_type || my_time(NULL)), \
8181 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
8182 ((secs) - utc_offset_secs))))
8184 static time_t toloc_dst(time_t utc) {
8187 utc += utc_offset_secs;
8188 if ((rsltmp = localtime(&utc)) == NULL) return -1;
8189 if (rsltmp->tm_isdst) utc += 3600;
8192 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
8193 ((gmtime_emulation_type || my_time(NULL)), \
8194 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
8195 ((secs) + utc_offset_secs))))
8197 #ifndef RTL_USES_UTC
8200 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
8201 DST starts on 1st sun of april at 02:00 std time
8202 ends on last sun of october at 02:00 dst time
8203 see the UCX management command reference, SET CONFIG TIMEZONE
8204 for formatting info.
8206 No, it's not as general as it should be, but then again, NOTHING
8207 will handle UK times in a sensible way.
8212 parse the DST start/end info:
8213 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
8217 tz_parse_startend(char *s, struct tm *w, int *past)
8219 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
8220 int ly, dozjd, d, m, n, hour, min, sec, j, k;
8225 if (!past) return 0;
8228 if (w->tm_year % 4 == 0) ly = 1;
8229 if (w->tm_year % 100 == 0) ly = 0;
8230 if (w->tm_year+1900 % 400 == 0) ly = 1;
8233 dozjd = isdigit(*s);
8234 if (*s == 'J' || *s == 'j' || dozjd) {
8235 if (!dozjd && !isdigit(*++s)) return 0;
8238 d = d*10 + *s++ - '0';
8240 d = d*10 + *s++ - '0';
8243 if (d == 0) return 0;
8244 if (d > 366) return 0;
8246 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
8249 } else if (*s == 'M' || *s == 'm') {
8250 if (!isdigit(*++s)) return 0;
8252 if (isdigit(*s)) m = 10*m + *s++ - '0';
8253 if (*s != '.') return 0;
8254 if (!isdigit(*++s)) return 0;
8256 if (n < 1 || n > 5) return 0;
8257 if (*s != '.') return 0;
8258 if (!isdigit(*++s)) return 0;
8260 if (d > 6) return 0;
8264 if (!isdigit(*++s)) return 0;
8266 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
8268 if (!isdigit(*++s)) return 0;
8270 if (isdigit(*s)) min = 10*min + *s++ - '0';
8272 if (!isdigit(*++s)) return 0;
8274 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
8284 if (w->tm_yday < d) goto before;
8285 if (w->tm_yday > d) goto after;
8287 if (w->tm_mon+1 < m) goto before;
8288 if (w->tm_mon+1 > m) goto after;
8290 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
8291 k = d - j; /* mday of first d */
8293 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
8294 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
8295 if (w->tm_mday < k) goto before;
8296 if (w->tm_mday > k) goto after;
8299 if (w->tm_hour < hour) goto before;
8300 if (w->tm_hour > hour) goto after;
8301 if (w->tm_min < min) goto before;
8302 if (w->tm_min > min) goto after;
8303 if (w->tm_sec < sec) goto before;
8317 /* parse the offset: (+|-)hh[:mm[:ss]] */
8320 tz_parse_offset(char *s, int *offset)
8322 int hour = 0, min = 0, sec = 0;
8325 if (!offset) return 0;
8327 if (*s == '-') {neg++; s++;}
8329 if (!isdigit(*s)) return 0;
8331 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
8332 if (hour > 24) return 0;
8334 if (!isdigit(*++s)) return 0;
8336 if (isdigit(*s)) min = min*10 + (*s++ - '0');
8337 if (min > 59) return 0;
8339 if (!isdigit(*++s)) return 0;
8341 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
8342 if (sec > 59) return 0;
8346 *offset = (hour*60+min)*60 + sec;
8347 if (neg) *offset = -*offset;
8352 input time is w, whatever type of time the CRTL localtime() uses.
8353 sets dst, the zone, and the gmtoff (seconds)
8355 caches the value of TZ and UCX$TZ env variables; note that
8356 my_setenv looks for these and sets a flag if they're changed
8359 We have to watch out for the "australian" case (dst starts in
8360 october, ends in april)...flagged by "reverse" and checked by
8361 scanning through the months of the previous year.
8366 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
8371 char *dstzone, *tz, *s_start, *s_end;
8372 int std_off, dst_off, isdst;
8373 int y, dststart, dstend;
8374 static char envtz[1025]; /* longer than any logical, symbol, ... */
8375 static char ucxtz[1025];
8376 static char reversed = 0;
8382 reversed = -1; /* flag need to check */
8383 envtz[0] = ucxtz[0] = '\0';
8384 tz = my_getenv("TZ",0);
8385 if (tz) strcpy(envtz, tz);
8386 tz = my_getenv("UCX$TZ",0);
8387 if (tz) strcpy(ucxtz, tz);
8388 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
8391 if (!*tz) tz = ucxtz;
8394 while (isalpha(*s)) s++;
8395 s = tz_parse_offset(s, &std_off);
8397 if (!*s) { /* no DST, hurray we're done! */
8403 while (isalpha(*s)) s++;
8404 s2 = tz_parse_offset(s, &dst_off);
8408 dst_off = std_off - 3600;
8411 if (!*s) { /* default dst start/end?? */
8412 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
8413 s = strchr(ucxtz,',');
8415 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
8417 if (*s != ',') return 0;
8420 when = _toutc(when); /* convert to utc */
8421 when = when - std_off; /* convert to pseudolocal time*/
8423 w2 = localtime(&when);
8426 s = tz_parse_startend(s_start,w2,&dststart);
8428 if (*s != ',') return 0;
8431 when = _toutc(when); /* convert to utc */
8432 when = when - dst_off; /* convert to pseudolocal time*/
8433 w2 = localtime(&when);
8434 if (w2->tm_year != y) { /* spans a year, just check one time */
8435 when += dst_off - std_off;
8436 w2 = localtime(&when);
8439 s = tz_parse_startend(s_end,w2,&dstend);
8442 if (reversed == -1) { /* need to check if start later than end */
8446 if (when < 2*365*86400) {
8447 when += 2*365*86400;
8451 w2 =localtime(&when);
8452 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
8454 for (j = 0; j < 12; j++) {
8455 w2 =localtime(&when);
8456 tz_parse_startend(s_start,w2,&ds);
8457 tz_parse_startend(s_end,w2,&de);
8458 if (ds != de) break;
8462 if (de && !ds) reversed = 1;
8465 isdst = dststart && !dstend;
8466 if (reversed) isdst = dststart || !dstend;
8469 if (dst) *dst = isdst;
8470 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
8471 if (isdst) tz = dstzone;
8473 while(isalpha(*tz)) *zone++ = *tz++;
8479 #endif /* !RTL_USES_UTC */
8481 /* my_time(), my_localtime(), my_gmtime()
8482 * By default traffic in UTC time values, using CRTL gmtime() or
8483 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
8484 * Note: We need to use these functions even when the CRTL has working
8485 * UTC support, since they also handle C<use vmsish qw(times);>
8487 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
8488 * Modified by Charles Bailey <bailey@newman.upenn.edu>
8491 /*{{{time_t my_time(time_t *timep)*/
8492 time_t Perl_my_time(pTHX_ time_t *timep)
8497 if (gmtime_emulation_type == 0) {
8499 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
8500 /* results of calls to gmtime() and localtime() */
8501 /* for same &base */
8503 gmtime_emulation_type++;
8504 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
8505 char off[LNM$C_NAMLENGTH+1];;
8507 gmtime_emulation_type++;
8508 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
8509 gmtime_emulation_type++;
8510 utc_offset_secs = 0;
8511 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
8513 else { utc_offset_secs = atol(off); }
8515 else { /* We've got a working gmtime() */
8516 struct tm gmt, local;
8519 tm_p = localtime(&base);
8521 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
8522 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
8523 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
8524 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
8530 # ifdef RTL_USES_UTC
8531 if (VMSISH_TIME) when = _toloc(when);
8533 if (!VMSISH_TIME) when = _toutc(when);
8536 if (timep != NULL) *timep = when;
8539 } /* end of my_time() */
8543 /*{{{struct tm *my_gmtime(const time_t *timep)*/
8545 Perl_my_gmtime(pTHX_ const time_t *timep)
8551 if (timep == NULL) {
8552 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8555 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
8559 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
8561 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
8562 return gmtime(&when);
8564 /* CRTL localtime() wants local time as input, so does no tz correction */
8565 rsltmp = localtime(&when);
8566 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
8569 } /* end of my_gmtime() */
8573 /*{{{struct tm *my_localtime(const time_t *timep)*/
8575 Perl_my_localtime(pTHX_ const time_t *timep)
8577 time_t when, whenutc;
8581 if (timep == NULL) {
8582 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8585 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
8586 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
8589 # ifdef RTL_USES_UTC
8591 if (VMSISH_TIME) when = _toutc(when);
8593 /* CRTL localtime() wants UTC as input, does tz correction itself */
8594 return localtime(&when);
8596 # else /* !RTL_USES_UTC */
8599 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
8600 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
8603 #ifndef RTL_USES_UTC
8604 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
8605 when = whenutc - offset; /* pseudolocal time*/
8608 /* CRTL localtime() wants local time as input, so does no tz correction */
8609 rsltmp = localtime(&when);
8610 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
8614 } /* end of my_localtime() */
8617 /* Reset definitions for later calls */
8618 #define gmtime(t) my_gmtime(t)
8619 #define localtime(t) my_localtime(t)
8620 #define time(t) my_time(t)
8623 /* my_utime - update modification time of a file
8624 * calling sequence is identical to POSIX utime(), but under
8625 * VMS only the modification time is changed; ODS-2 does not
8626 * maintain access times. Restrictions differ from the POSIX
8627 * definition in that the time can be changed as long as the
8628 * caller has permission to execute the necessary IO$_MODIFY $QIO;
8629 * no separate checks are made to insure that the caller is the
8630 * owner of the file or has special privs enabled.
8631 * Code here is based on Joe Meadows' FILE utility.
8634 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
8635 * to VMS epoch (01-JAN-1858 00:00:00.00)
8636 * in 100 ns intervals.
8638 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
8640 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
8641 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
8645 long int bintime[2], len = 2, lowbit, unixtime,
8646 secscale = 10000000; /* seconds --> 100 ns intervals */
8647 unsigned long int chan, iosb[2], retsts;
8648 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
8649 struct FAB myfab = cc$rms_fab;
8650 struct NAM mynam = cc$rms_nam;
8651 #if defined (__DECC) && defined (__VAX)
8652 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
8653 * at least through VMS V6.1, which causes a type-conversion warning.
8655 # pragma message save
8656 # pragma message disable cvtdiftypes
8658 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
8659 struct fibdef myfib;
8660 #if defined (__DECC) && defined (__VAX)
8661 /* This should be right after the declaration of myatr, but due
8662 * to a bug in VAX DEC C, this takes effect a statement early.
8664 # pragma message restore
8666 /* cast ok for read only parameter */
8667 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
8668 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
8669 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
8671 if (file == NULL || *file == '\0') {
8673 set_vaxc_errno(LIB$_INVARG);
8676 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
8678 if (utimes != NULL) {
8679 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
8680 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
8681 * Since time_t is unsigned long int, and lib$emul takes a signed long int
8682 * as input, we force the sign bit to be clear by shifting unixtime right
8683 * one bit, then multiplying by an extra factor of 2 in lib$emul().
8685 lowbit = (utimes->modtime & 1) ? secscale : 0;
8686 unixtime = (long int) utimes->modtime;
8688 /* If input was UTC; convert to local for sys svc */
8689 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
8691 unixtime >>= 1; secscale <<= 1;
8692 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
8693 if (!(retsts & 1)) {
8695 set_vaxc_errno(retsts);
8698 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
8699 if (!(retsts & 1)) {
8701 set_vaxc_errno(retsts);
8706 /* Just get the current time in VMS format directly */
8707 retsts = sys$gettim(bintime);
8708 if (!(retsts & 1)) {
8710 set_vaxc_errno(retsts);
8715 myfab.fab$l_fna = vmsspec;
8716 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
8717 myfab.fab$l_nam = &mynam;
8718 mynam.nam$l_esa = esa;
8719 mynam.nam$b_ess = (unsigned char) sizeof esa;
8720 mynam.nam$l_rsa = rsa;
8721 mynam.nam$b_rss = (unsigned char) sizeof rsa;
8722 if (decc_efs_case_preserve)
8723 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
8725 /* Look for the file to be affected, letting RMS parse the file
8726 * specification for us as well. I have set errno using only
8727 * values documented in the utime() man page for VMS POSIX.
8729 retsts = sys$parse(&myfab,0,0);
8730 if (!(retsts & 1)) {
8731 set_vaxc_errno(retsts);
8732 if (retsts == RMS$_PRV) set_errno(EACCES);
8733 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
8734 else set_errno(EVMSERR);
8737 retsts = sys$search(&myfab,0,0);
8738 if (!(retsts & 1)) {
8739 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
8740 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
8741 set_vaxc_errno(retsts);
8742 if (retsts == RMS$_PRV) set_errno(EACCES);
8743 else if (retsts == RMS$_FNF) set_errno(ENOENT);
8744 else set_errno(EVMSERR);
8748 devdsc.dsc$w_length = mynam.nam$b_dev;
8749 /* cast ok for read only parameter */
8750 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
8752 retsts = sys$assign(&devdsc,&chan,0,0);
8753 if (!(retsts & 1)) {
8754 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
8755 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
8756 set_vaxc_errno(retsts);
8757 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
8758 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
8759 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
8760 else set_errno(EVMSERR);
8764 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
8765 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
8767 memset((void *) &myfib, 0, sizeof myfib);
8768 #if defined(__DECC) || defined(__DECCXX)
8769 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
8770 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
8771 /* This prevents the revision time of the file being reset to the current
8772 * time as a result of our IO$_MODIFY $QIO. */
8773 myfib.fib$l_acctl = FIB$M_NORECORD;
8775 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
8776 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
8777 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
8779 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
8780 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
8781 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
8782 _ckvmssts(sys$dassgn(chan));
8783 if (retsts & 1) retsts = iosb[0];
8784 if (!(retsts & 1)) {
8785 set_vaxc_errno(retsts);
8786 if (retsts == SS$_NOPRIV) set_errno(EACCES);
8787 else set_errno(EVMSERR);
8792 } /* end of my_utime() */
8796 * flex_stat, flex_lstat, flex_fstat
8797 * basic stat, but gets it right when asked to stat
8798 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
8801 #ifndef _USE_STD_STAT
8802 /* encode_dev packs a VMS device name string into an integer to allow
8803 * simple comparisons. This can be used, for example, to check whether two
8804 * files are located on the same device, by comparing their encoded device
8805 * names. Even a string comparison would not do, because stat() reuses the
8806 * device name buffer for each call; so without encode_dev, it would be
8807 * necessary to save the buffer and use strcmp (this would mean a number of
8808 * changes to the standard Perl code, to say nothing of what a Perl script
8811 * The device lock id, if it exists, should be unique (unless perhaps compared
8812 * with lock ids transferred from other nodes). We have a lock id if the disk is
8813 * mounted cluster-wide, which is when we tend to get long (host-qualified)
8814 * device names. Thus we use the lock id in preference, and only if that isn't
8815 * available, do we try to pack the device name into an integer (flagged by
8816 * the sign bit (LOCKID_MASK) being set).
8818 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
8819 * name and its encoded form, but it seems very unlikely that we will find
8820 * two files on different disks that share the same encoded device names,
8821 * and even more remote that they will share the same file id (if the test
8822 * is to check for the same file).
8824 * A better method might be to use sys$device_scan on the first call, and to
8825 * search for the device, returning an index into the cached array.
8826 * The number returned would be more intelligable.
8827 * This is probably not worth it, and anyway would take quite a bit longer
8828 * on the first call.
8830 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
8831 static mydev_t encode_dev (pTHX_ const char *dev)
8834 unsigned long int f;
8839 if (!dev || !dev[0]) return 0;
8843 struct dsc$descriptor_s dev_desc;
8844 unsigned long int status, lockid, item = DVI$_LOCKID;
8846 /* For cluster-mounted disks, the disk lock identifier is unique, so we
8847 can try that first. */
8848 dev_desc.dsc$w_length = strlen (dev);
8849 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
8850 dev_desc.dsc$b_class = DSC$K_CLASS_S;
8851 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
8852 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
8853 if (lockid) return (lockid & ~LOCKID_MASK);
8857 /* Otherwise we try to encode the device name */
8861 for (q = dev + strlen(dev); q--; q >= dev) {
8864 else if (isalpha (toupper (*q)))
8865 c= toupper (*q) - 'A' + (char)10;
8867 continue; /* Skip '$'s */
8869 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
8871 enc += f * (unsigned long int) c;
8873 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
8875 } /* end of encode_dev() */
8878 static char namecache[NAM$C_MAXRSS+1];
8881 is_null_device(name)
8884 if (decc_bug_devnull != 0) {
8885 if (strcmp("/dev/null", name) == 0) /* temp hack */
8888 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
8889 The underscore prefix, controller letter, and unit number are
8890 independently optional; for our purposes, the colon punctuation
8891 is not. The colon can be trailed by optional directory and/or
8892 filename, but two consecutive colons indicates a nodename rather
8893 than a device. [pr] */
8894 if (*name == '_') ++name;
8895 if (tolower(*name++) != 'n') return 0;
8896 if (tolower(*name++) != 'l') return 0;
8897 if (tolower(*name) == 'a') ++name;
8898 if (*name == '0') ++name;
8899 return (*name++ == ':') && (*name != ':');
8902 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
8903 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
8904 * subset of the applicable information.
8907 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, const Stat_t *statbufp)
8909 char fname_phdev[NAM$C_MAXRSS+1];
8910 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8911 /* Namecache not workable with symbolic links, as symbolic links do
8912 * not have extensions and directories do in VMS mode. So in order
8913 * to test this, the did and ino_t must be used.
8915 * Fix-me - Hide the information in the new stat structure
8916 * Get rid of the namecache.
8918 if (decc_posix_compliant_pathnames == 0)
8920 if (statbufp == &PL_statcache)
8921 return cando_by_name(bit,effective,namecache);
8923 char fname[NAM$C_MAXRSS+1];
8924 unsigned long int retsts;
8925 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
8926 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8928 /* If the struct mystat is stale, we're OOL; stat() overwrites the
8929 device name on successive calls */
8930 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
8931 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
8932 namdsc.dsc$a_pointer = fname;
8933 namdsc.dsc$w_length = sizeof fname - 1;
8935 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
8936 &namdsc,&namdsc.dsc$w_length,0,0);
8938 fname[namdsc.dsc$w_length] = '\0';
8940 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
8941 * but if someone has redefined that logical, Perl gets very lost. Since
8942 * we have the physical device name from the stat buffer, just paste it on.
8944 strcpy( fname_phdev, statbufp->st_devnam );
8945 strcat( fname_phdev, strrchr(fname, ':') );
8947 return cando_by_name(bit,effective,fname_phdev);
8949 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
8950 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
8954 return FALSE; /* Should never get to here */
8956 } /* end of cando() */
8960 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
8962 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, const char *fname)
8964 static char usrname[L_cuserid];
8965 static struct dsc$descriptor_s usrdsc =
8966 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
8967 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
8968 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
8969 unsigned short int retlen, trnlnm_iter_count;
8970 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8971 union prvdef curprv;
8972 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
8973 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
8974 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
8975 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
8977 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
8979 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8981 if (!fname || !*fname) return FALSE;
8982 /* Make sure we expand logical names, since sys$check_access doesn't */
8983 if (!strpbrk(fname,"/]>:")) {
8984 strcpy(fileified,fname);
8985 trnlnm_iter_count = 0;
8986 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
8987 trnlnm_iter_count++;
8988 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
8992 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
8993 retlen = namdsc.dsc$w_length = strlen(vmsname);
8994 namdsc.dsc$a_pointer = vmsname;
8995 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
8996 vmsname[retlen-1] == ':') {
8997 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
8998 namdsc.dsc$w_length = strlen(fileified);
8999 namdsc.dsc$a_pointer = fileified;
9003 case S_IXUSR: case S_IXGRP: case S_IXOTH:
9004 access = ARM$M_EXECUTE; break;
9005 case S_IRUSR: case S_IRGRP: case S_IROTH:
9006 access = ARM$M_READ; break;
9007 case S_IWUSR: case S_IWGRP: case S_IWOTH:
9008 access = ARM$M_WRITE; break;
9009 case S_IDUSR: case S_IDGRP: case S_IDOTH:
9010 access = ARM$M_DELETE; break;
9015 /* Before we call $check_access, create a user profile with the current
9016 * process privs since otherwise it just uses the default privs from the
9017 * UAF and might give false positives or negatives. This only works on
9018 * VMS versions v6.0 and later since that's when sys$create_user_profile
9022 /* get current process privs and username */
9023 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9026 #if defined(__VMS_VER) && __VMS_VER >= 60000000
9028 /* find out the space required for the profile */
9029 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
9030 &usrprodsc.dsc$w_length,0));
9032 /* allocate space for the profile and get it filled in */
9033 Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
9034 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
9035 &usrprodsc.dsc$w_length,0));
9037 /* use the profile to check access to the file; free profile & analyze results */
9038 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
9039 Safefree(usrprodsc.dsc$a_pointer);
9040 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
9044 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
9048 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
9049 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
9050 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
9051 set_vaxc_errno(retsts);
9052 if (retsts == SS$_NOPRIV) set_errno(EACCES);
9053 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
9054 else set_errno(ENOENT);
9057 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
9062 return FALSE; /* Should never get here */
9064 } /* end of cando_by_name() */
9068 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
9070 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
9072 if (!fstat(fd,(stat_t *) statbufp)) {
9073 if (statbufp == (Stat_t *) &PL_statcache) {
9076 /* Save name for cando by name in VMS format */
9077 cptr = getname(fd, namecache, 1);
9079 /* This should not happen, but just in case */
9081 namecache[0] = '\0';
9083 memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9084 #ifndef _USE_STD_STAT
9085 strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9086 statbufp->st_devnam[63] = 0;
9087 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9090 * The device is only encoded so that Perl_cando can use it to
9091 * look up ACLS. So rmsexpand it to the 255 character version
9092 * and store it in ->st_devnam. rmsexpand needs to be fixed
9093 * for long filenames and symbolic links first. This also seems
9094 * to remove the need for a namecache that could be stale.
9098 # ifdef RTL_USES_UTC
9101 statbufp->st_mtime = _toloc(statbufp->st_mtime);
9102 statbufp->st_atime = _toloc(statbufp->st_atime);
9103 statbufp->st_ctime = _toloc(statbufp->st_ctime);
9108 if (!VMSISH_TIME) { /* Return UTC instead of local time */
9112 statbufp->st_mtime = _toutc(statbufp->st_mtime);
9113 statbufp->st_atime = _toutc(statbufp->st_atime);
9114 statbufp->st_ctime = _toutc(statbufp->st_ctime);
9121 } /* end of flex_fstat() */
9124 #if !defined(__VAX) && __CRTL_VER >= 80200000
9132 #define lstat(_x, _y) stat(_x, _y)
9136 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
9138 char fileified[NAM$C_MAXRSS+1];
9139 char temp_fspec[NAM$C_MAXRSS+300];
9141 int saved_errno, saved_vaxc_errno;
9143 if (!fspec) return retval;
9144 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
9145 strcpy(temp_fspec, fspec);
9146 if (statbufp == (Stat_t *) &PL_statcache)
9147 do_tovmsspec(temp_fspec,namecache,0);
9148 if (decc_bug_devnull != 0) {
9149 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
9150 memset(statbufp,0,sizeof *statbufp);
9151 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
9152 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
9153 statbufp->st_uid = 0x00010001;
9154 statbufp->st_gid = 0x0001;
9155 time((time_t *)&statbufp->st_mtime);
9156 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
9161 /* Try for a directory name first. If fspec contains a filename without
9162 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9163 * and sea:[wine.dark]water. exist, we prefer the directory here.
9164 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
9165 * not sea:[wine.dark]., if the latter exists. If the intended target is
9166 * the file with null type, specify this by calling flex_stat() with
9167 * a '.' at the end of fspec.
9169 * If we are in Posix filespec mode, accept the filename as is.
9171 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9172 if (decc_posix_compliant_pathnames == 0) {
9174 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
9175 if (lstat_flag == 0)
9176 retval = stat(fileified,(stat_t *) statbufp);
9178 retval = lstat(fileified,(stat_t *) statbufp);
9179 if (!retval && statbufp == (Stat_t *) &PL_statcache)
9180 strcpy(namecache,fileified);
9183 if (lstat_flag == 0)
9184 retval = stat(temp_fspec,(stat_t *) statbufp);
9186 retval = lstat(temp_fspec,(stat_t *) statbufp);
9188 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9190 if (lstat_flag == 0)
9191 retval = stat(temp_fspec,(stat_t *) statbufp);
9193 retval = lstat(temp_fspec,(stat_t *) statbufp);
9197 memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9198 #ifndef _USE_STD_STAT
9199 strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9200 statbufp->st_devnam[63] = 0;
9201 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9204 * The device is only encoded so that Perl_cando can use it to
9205 * look up ACLS. So rmsexpand it to the 255 character version
9206 * and store it in ->st_devnam. rmsexpand needs to be fixed
9207 * for long filenames and symbolic links first. This also seems
9208 * to remove the need for a namecache that could be stale.
9211 # ifdef RTL_USES_UTC
9214 statbufp->st_mtime = _toloc(statbufp->st_mtime);
9215 statbufp->st_atime = _toloc(statbufp->st_atime);
9216 statbufp->st_ctime = _toloc(statbufp->st_ctime);
9221 if (!VMSISH_TIME) { /* Return UTC instead of local time */
9225 statbufp->st_mtime = _toutc(statbufp->st_mtime);
9226 statbufp->st_atime = _toutc(statbufp->st_atime);
9227 statbufp->st_ctime = _toutc(statbufp->st_ctime);
9231 /* If we were successful, leave errno where we found it */
9232 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
9235 } /* end of flex_stat_int() */
9238 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
9240 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
9242 return Perl_flex_stat_int(fspec, statbufp, 0);
9246 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
9248 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
9250 return Perl_flex_stat_int(fspec, statbufp, 1);
9255 /*{{{char *my_getlogin()*/
9256 /* VMS cuserid == Unix getlogin, except calling sequence */
9260 static char user[L_cuserid];
9261 return cuserid(user);
9266 /* rmscopy - copy a file using VMS RMS routines
9268 * Copies contents and attributes of spec_in to spec_out, except owner
9269 * and protection information. Name and type of spec_in are used as
9270 * defaults for spec_out. The third parameter specifies whether rmscopy()
9271 * should try to propagate timestamps from the input file to the output file.
9272 * If it is less than 0, no timestamps are preserved. If it is 0, then
9273 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
9274 * propagated to the output file at creation iff the output file specification
9275 * did not contain an explicit name or type, and the revision date is always
9276 * updated at the end of the copy operation. If it is greater than 0, then
9277 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
9278 * other than the revision date should be propagated, and bit 1 indicates
9279 * that the revision date should be propagated.
9281 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
9283 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
9284 * Incorporates, with permission, some code from EZCOPY by Tim Adye
9285 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
9286 * as part of the Perl standard distribution under the terms of the
9287 * GNU General Public License or the Perl Artistic License. Copies
9288 * of each may be found in the Perl standard distribution.
9290 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
9292 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
9294 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
9295 rsa[NAM$C_MAXRSS], ubf[32256];
9296 unsigned long int i, sts, sts2;
9297 struct FAB fab_in, fab_out;
9298 struct RAB rab_in, rab_out;
9300 struct XABDAT xabdat;
9301 struct XABFHC xabfhc;
9302 struct XABRDT xabrdt;
9303 struct XABSUM xabsum;
9305 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
9306 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
9307 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9311 fab_in = cc$rms_fab;
9312 fab_in.fab$l_fna = vmsin;
9313 fab_in.fab$b_fns = strlen(vmsin);
9314 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
9315 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
9316 fab_in.fab$l_fop = FAB$M_SQO;
9317 fab_in.fab$l_nam = &nam;
9318 fab_in.fab$l_xab = (void *) &xabdat;
9321 nam.nam$l_rsa = rsa;
9322 nam.nam$b_rss = sizeof(rsa);
9323 nam.nam$l_esa = esa;
9324 nam.nam$b_ess = sizeof (esa);
9325 nam.nam$b_esl = nam.nam$b_rsl = 0;
9326 #ifdef NAM$M_NO_SHORT_UPCASE
9327 if (decc_efs_case_preserve)
9328 nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9331 xabdat = cc$rms_xabdat; /* To get creation date */
9332 xabdat.xab$l_nxt = (void *) &xabfhc;
9334 xabfhc = cc$rms_xabfhc; /* To get record length */
9335 xabfhc.xab$l_nxt = (void *) &xabsum;
9337 xabsum = cc$rms_xabsum; /* To get key and area information */
9339 if (!((sts = sys$open(&fab_in)) & 1)) {
9340 set_vaxc_errno(sts);
9342 case RMS$_FNF: case RMS$_DNF:
9343 set_errno(ENOENT); break;
9345 set_errno(ENOTDIR); break;
9347 set_errno(ENODEV); break;
9349 set_errno(EINVAL); break;
9351 set_errno(EACCES); break;
9359 fab_out.fab$w_ifi = 0;
9360 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
9361 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
9362 fab_out.fab$l_fop = FAB$M_SQO;
9363 fab_out.fab$l_fna = vmsout;
9364 fab_out.fab$b_fns = strlen(vmsout);
9365 fab_out.fab$l_dna = nam.nam$l_name;
9366 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
9368 if (preserve_dates == 0) { /* Act like DCL COPY */
9369 nam.nam$b_nop |= NAM$M_SYNCHK;
9370 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
9371 if (!((sts = sys$parse(&fab_out)) & 1)) {
9372 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
9373 set_vaxc_errno(sts);
9376 fab_out.fab$l_xab = (void *) &xabdat;
9377 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
9379 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
9380 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
9381 preserve_dates =0; /* bitmask from this point forward */
9383 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
9384 if (!((sts = sys$create(&fab_out)) & 1)) {
9385 set_vaxc_errno(sts);
9388 set_errno(ENOENT); break;
9390 set_errno(ENOTDIR); break;
9392 set_errno(ENODEV); break;
9394 set_errno(EINVAL); break;
9396 set_errno(EACCES); break;
9402 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
9403 if (preserve_dates & 2) {
9404 /* sys$close() will process xabrdt, not xabdat */
9405 xabrdt = cc$rms_xabrdt;
9407 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
9409 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
9410 * is unsigned long[2], while DECC & VAXC use a struct */
9411 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
9413 fab_out.fab$l_xab = (void *) &xabrdt;
9416 rab_in = cc$rms_rab;
9417 rab_in.rab$l_fab = &fab_in;
9418 rab_in.rab$l_rop = RAB$M_BIO;
9419 rab_in.rab$l_ubf = ubf;
9420 rab_in.rab$w_usz = sizeof ubf;
9421 if (!((sts = sys$connect(&rab_in)) & 1)) {
9422 sys$close(&fab_in); sys$close(&fab_out);
9423 set_errno(EVMSERR); set_vaxc_errno(sts);
9427 rab_out = cc$rms_rab;
9428 rab_out.rab$l_fab = &fab_out;
9429 rab_out.rab$l_rbf = ubf;
9430 if (!((sts = sys$connect(&rab_out)) & 1)) {
9431 sys$close(&fab_in); sys$close(&fab_out);
9432 set_errno(EVMSERR); set_vaxc_errno(sts);
9436 while ((sts = sys$read(&rab_in))) { /* always true */
9437 if (sts == RMS$_EOF) break;
9438 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
9439 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
9440 sys$close(&fab_in); sys$close(&fab_out);
9441 set_errno(EVMSERR); set_vaxc_errno(sts);
9446 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
9447 sys$close(&fab_in); sys$close(&fab_out);
9448 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
9450 set_errno(EVMSERR); set_vaxc_errno(sts);
9456 } /* end of rmscopy() */
9460 /*** The following glue provides 'hooks' to make some of the routines
9461 * from this file available from Perl. These routines are sufficiently
9462 * basic, and are required sufficiently early in the build process,
9463 * that's it's nice to have them available to miniperl as well as the
9464 * full Perl, so they're set up here instead of in an extension. The
9465 * Perl code which handles importation of these names into a given
9466 * package lives in [.VMS]Filespec.pm in @INC.
9470 rmsexpand_fromperl(pTHX_ CV *cv)
9473 char *fspec, *defspec = NULL, *rslt;
9476 if (!items || items > 2)
9477 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
9478 fspec = SvPV(ST(0),n_a);
9479 if (!fspec || !*fspec) XSRETURN_UNDEF;
9480 if (items == 2) defspec = SvPV(ST(1),n_a);
9482 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
9483 ST(0) = sv_newmortal();
9484 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
9489 vmsify_fromperl(pTHX_ CV *cv)
9495 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
9496 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
9497 ST(0) = sv_newmortal();
9498 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
9503 unixify_fromperl(pTHX_ CV *cv)
9509 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
9510 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
9511 ST(0) = sv_newmortal();
9512 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
9517 fileify_fromperl(pTHX_ CV *cv)
9523 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
9524 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
9525 ST(0) = sv_newmortal();
9526 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
9531 pathify_fromperl(pTHX_ CV *cv)
9537 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
9538 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
9539 ST(0) = sv_newmortal();
9540 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
9545 vmspath_fromperl(pTHX_ CV *cv)
9551 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
9552 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
9553 ST(0) = sv_newmortal();
9554 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
9559 unixpath_fromperl(pTHX_ CV *cv)
9565 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
9566 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
9567 ST(0) = sv_newmortal();
9568 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
9573 candelete_fromperl(pTHX_ CV *cv)
9576 char fspec[NAM$C_MAXRSS+1], *fsp;
9581 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
9583 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
9584 if (SvTYPE(mysv) == SVt_PVGV) {
9585 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
9586 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9593 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
9594 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9600 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
9605 rmscopy_fromperl(pTHX_ CV *cv)
9608 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
9610 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9611 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9612 unsigned long int sts;
9617 if (items < 2 || items > 3)
9618 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
9620 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
9621 if (SvTYPE(mysv) == SVt_PVGV) {
9622 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
9623 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9630 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
9631 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9636 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
9637 if (SvTYPE(mysv) == SVt_PVGV) {
9638 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
9639 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9646 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
9647 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9652 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
9654 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
9660 mod2fname(pTHX_ CV *cv)
9663 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
9664 workbuff[NAM$C_MAXRSS*1 + 1];
9665 int total_namelen = 3, counter, num_entries;
9666 /* ODS-5 ups this, but we want to be consistent, so... */
9667 int max_name_len = 39;
9668 AV *in_array = (AV *)SvRV(ST(0));
9670 num_entries = av_len(in_array);
9672 /* All the names start with PL_. */
9673 strcpy(ultimate_name, "PL_");
9675 /* Clean up our working buffer */
9676 Zero(work_name, sizeof(work_name), char);
9678 /* Run through the entries and build up a working name */
9679 for(counter = 0; counter <= num_entries; counter++) {
9680 /* If it's not the first name then tack on a __ */
9682 strcat(work_name, "__");
9684 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
9688 /* Check to see if we actually have to bother...*/
9689 if (strlen(work_name) + 3 <= max_name_len) {
9690 strcat(ultimate_name, work_name);
9692 /* It's too darned big, so we need to go strip. We use the same */
9693 /* algorithm as xsubpp does. First, strip out doubled __ */
9694 char *source, *dest, last;
9697 for (source = work_name; *source; source++) {
9698 if (last == *source && last == '_') {
9704 /* Go put it back */
9705 strcpy(work_name, workbuff);
9706 /* Is it still too big? */
9707 if (strlen(work_name) + 3 > max_name_len) {
9708 /* Strip duplicate letters */
9711 for (source = work_name; *source; source++) {
9712 if (last == toupper(*source)) {
9716 last = toupper(*source);
9718 strcpy(work_name, workbuff);
9721 /* Is it *still* too big? */
9722 if (strlen(work_name) + 3 > max_name_len) {
9723 /* Too bad, we truncate */
9724 work_name[max_name_len - 2] = 0;
9726 strcat(ultimate_name, work_name);
9729 /* Okay, return it */
9730 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
9735 hushexit_fromperl(pTHX_ CV *cv)
9740 VMSISH_HUSHED = SvTRUE(ST(0));
9742 ST(0) = boolSV(VMSISH_HUSHED);
9748 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
9751 vms_realpath_fromperl(pTHX_ CV *cv)
9754 char *fspec, *rslt_spec, *rslt;
9757 if (!items || items != 1)
9758 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
9760 fspec = SvPV(ST(0),n_a);
9761 if (!fspec || !*fspec) XSRETURN_UNDEF;
9763 Newx(rslt_spec, VMS_MAXRSS + 1, char);
9764 rslt = do_vms_realpath(fspec, rslt_spec);
9765 ST(0) = sv_newmortal();
9767 sv_usepvn(ST(0),rslt,strlen(rslt));
9769 Safefree(rslt_spec);
9774 #if __CRTL_VER >= 70301000 && !defined(__VAX)
9775 int do_vms_case_tolerant(void);
9778 vms_case_tolerant_fromperl(pTHX_ CV *cv)
9781 ST(0) = boolSV(do_vms_case_tolerant());
9787 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
9788 struct interp_intern *dst)
9790 memcpy(dst,src,sizeof(struct interp_intern));
9794 Perl_sys_intern_clear(pTHX)
9799 Perl_sys_intern_init(pTHX)
9801 unsigned int ix = RAND_MAX;
9806 /* fix me later to track running under GNV */
9807 /* this allows some limited testing */
9808 MY_POSIX_EXIT = decc_filename_unix_report;
9811 MY_INV_RAND_MAX = 1./x;
9815 init_os_extras(void)
9818 char* file = __FILE__;
9819 char temp_buff[512];
9820 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
9821 no_translate_barewords = TRUE;
9823 no_translate_barewords = FALSE;
9826 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
9827 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
9828 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
9829 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
9830 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
9831 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
9832 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
9833 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
9834 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
9835 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
9836 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
9838 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
9840 #if __CRTL_VER >= 70301000 && !defined(__VAX)
9841 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
9844 store_pipelocs(aTHX); /* will redo any earlier attempts */
9851 #if __CRTL_VER == 80200000
9852 /* This missed getting in to the DECC SDK for 8.2 */
9853 char *realpath(const char *file_name, char * resolved_name, ...);
9856 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
9857 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
9858 * The perl fallback routine to provide realpath() is not as efficient
9862 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
9864 return realpath(filespec, outbuf);
9868 /* External entry points */
9869 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
9870 { return do_vms_realpath(filespec, outbuf); }
9872 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
9877 #if __CRTL_VER >= 70301000 && !defined(__VAX)
9880 /*{{{int do_vms_case_tolerant(void)*/
9881 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
9882 * controlled by a process setting.
9884 int do_vms_case_tolerant(void)
9886 return vms_process_case_tolerant;
9889 /* External entry points */
9890 int Perl_vms_case_tolerant(void)
9891 { return do_vms_case_tolerant(); }
9893 int Perl_vms_case_tolerant(void)
9894 { return vms_process_case_tolerant; }
9898 /* Start of DECC RTL Feature handling */
9900 static int sys_trnlnm
9901 (const char * logname,
9905 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
9906 const unsigned long attr = LNM$M_CASE_BLIND;
9907 struct dsc$descriptor_s name_dsc;
9909 unsigned short result;
9910 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
9913 name_dsc.dsc$w_length = strlen(logname);
9914 name_dsc.dsc$a_pointer = (char *)logname;
9915 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
9916 name_dsc.dsc$b_class = DSC$K_CLASS_S;
9918 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
9920 if ($VMS_STATUS_SUCCESS(status)) {
9922 /* Null terminate and return the string */
9923 /*--------------------------------------*/
9930 static int sys_crelnm
9931 (const char * logname,
9935 const char * proc_table = "LNM$PROCESS_TABLE";
9936 struct dsc$descriptor_s proc_table_dsc;
9937 struct dsc$descriptor_s logname_dsc;
9938 struct itmlst_3 item_list[2];
9940 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
9941 proc_table_dsc.dsc$w_length = strlen(proc_table);
9942 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
9943 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
9945 logname_dsc.dsc$a_pointer = (char *) logname;
9946 logname_dsc.dsc$w_length = strlen(logname);
9947 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
9948 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
9950 item_list[0].buflen = strlen(value);
9951 item_list[0].itmcode = LNM$_STRING;
9952 item_list[0].bufadr = (char *)value;
9953 item_list[0].retlen = NULL;
9955 item_list[1].buflen = 0;
9956 item_list[1].itmcode = 0;
9958 ret_val = sys$crelnm
9960 (const struct dsc$descriptor_s *)&proc_table_dsc,
9961 (const struct dsc$descriptor_s *)&logname_dsc,
9963 (const struct item_list_3 *) item_list);
9969 /* C RTL Feature settings */
9971 static int set_features
9972 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
9973 int (* cli_routine)(void), /* Not documented */
9974 void *image_info) /* Not documented */
9981 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
9982 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
9983 unsigned long case_perm;
9984 unsigned long case_image;
9986 /* hacks to see if known bugs are still present for testing */
9988 /* Readdir is returning filenames in VMS syntax always */
9989 decc_bug_readdir_efs1 = 1;
9990 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
9991 if ($VMS_STATUS_SUCCESS(status)) {
9992 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
9993 decc_bug_readdir_efs1 = 1;
9995 decc_bug_readdir_efs1 = 0;
9998 /* PCP mode requires creating /dev/null special device file */
9999 decc_bug_devnull = 0;
10000 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
10001 if ($VMS_STATUS_SUCCESS(status)) {
10002 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10003 decc_bug_devnull = 1;
10006 /* fgetname returning a VMS name in UNIX mode */
10007 decc_bug_fgetname = 1;
10008 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
10009 if ($VMS_STATUS_SUCCESS(status)) {
10010 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10011 decc_bug_fgetname = 1;
10013 decc_bug_fgetname = 0;
10016 /* UNIX directory names with no paths are broken in a lot of places */
10017 decc_dir_barename = 1;
10018 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
10019 if ($VMS_STATUS_SUCCESS(status)) {
10020 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10021 decc_dir_barename = 1;
10023 decc_dir_barename = 0;
10026 #if __CRTL_VER >= 70300000 && !defined(__VAX)
10027 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
10029 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
10030 if (decc_disable_to_vms_logname_translation < 0)
10031 decc_disable_to_vms_logname_translation = 0;
10034 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
10036 decc_efs_case_preserve = decc$feature_get_value(s, 1);
10037 if (decc_efs_case_preserve < 0)
10038 decc_efs_case_preserve = 0;
10041 s = decc$feature_get_index("DECC$EFS_CHARSET");
10043 decc_efs_charset = decc$feature_get_value(s, 1);
10044 if (decc_efs_charset < 0)
10045 decc_efs_charset = 0;
10048 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
10050 decc_filename_unix_report = decc$feature_get_value(s, 1);
10051 if (decc_filename_unix_report > 0)
10052 decc_filename_unix_report = 1;
10054 decc_filename_unix_report = 0;
10057 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
10059 decc_filename_unix_only = decc$feature_get_value(s, 1);
10060 if (decc_filename_unix_only > 0) {
10061 decc_filename_unix_only = 1;
10064 decc_filename_unix_only = 0;
10068 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
10070 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
10071 if (decc_filename_unix_no_version < 0)
10072 decc_filename_unix_no_version = 0;
10075 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
10077 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
10078 if (decc_readdir_dropdotnotype < 0)
10079 decc_readdir_dropdotnotype = 0;
10082 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
10083 if ($VMS_STATUS_SUCCESS(status)) {
10084 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
10086 dflt = decc$feature_get_value(s, 4);
10088 decc_disable_posix_root = decc$feature_get_value(s, 1);
10089 if (decc_disable_posix_root <= 0) {
10090 decc$feature_set_value(s, 1, 1);
10091 decc_disable_posix_root = 1;
10095 /* Traditionally Perl assumes this is off */
10096 decc_disable_posix_root = 1;
10097 decc$feature_set_value(s, 1, 1);
10102 #if __CRTL_VER >= 80200000
10103 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
10105 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
10106 if (decc_posix_compliant_pathnames < 0)
10107 decc_posix_compliant_pathnames = 0;
10108 if (decc_posix_compliant_pathnames > 4)
10109 decc_posix_compliant_pathnames = 0;
10114 status = sys_trnlnm
10115 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
10116 if ($VMS_STATUS_SUCCESS(status)) {
10117 val_str[0] = _toupper(val_str[0]);
10118 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10119 decc_disable_to_vms_logname_translation = 1;
10124 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
10125 if ($VMS_STATUS_SUCCESS(status)) {
10126 val_str[0] = _toupper(val_str[0]);
10127 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10128 decc_efs_case_preserve = 1;
10133 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
10134 if ($VMS_STATUS_SUCCESS(status)) {
10135 val_str[0] = _toupper(val_str[0]);
10136 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10137 decc_filename_unix_report = 1;
10140 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
10141 if ($VMS_STATUS_SUCCESS(status)) {
10142 val_str[0] = _toupper(val_str[0]);
10143 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10144 decc_filename_unix_only = 1;
10145 decc_filename_unix_report = 1;
10148 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
10149 if ($VMS_STATUS_SUCCESS(status)) {
10150 val_str[0] = _toupper(val_str[0]);
10151 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10152 decc_filename_unix_no_version = 1;
10155 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
10156 if ($VMS_STATUS_SUCCESS(status)) {
10157 val_str[0] = _toupper(val_str[0]);
10158 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10159 decc_readdir_dropdotnotype = 1;
10166 /* Report true case tolerance */
10167 /*----------------------------*/
10168 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
10169 if (!$VMS_STATUS_SUCCESS(status))
10170 case_perm = PPROP$K_CASE_BLIND;
10171 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
10172 if (!$VMS_STATUS_SUCCESS(status))
10173 case_image = PPROP$K_CASE_BLIND;
10174 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
10175 (case_image == PPROP$K_CASE_SENSITIVE))
10176 vms_process_case_tolerant = 0;
10181 /* CRTL can be initialized past this point, but not before. */
10182 /* DECC$CRTL_INIT(); */
10188 /* DECC dependent attributes */
10189 #if __DECC_VER < 60560002
10191 #define not_executable
10193 #define relative ,rel
10194 #define not_executable ,noexe
10197 #pragma extern_model save
10198 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
10200 const __align (LONGWORD) int spare[8] = {0};
10201 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
10204 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
10205 nowrt,noshr relative not_executable
10207 const long vms_cc_features = (const long)set_features;
10210 ** Force a reference to LIB$INITIALIZE to ensure it
10211 ** exists in the image.
10213 int lib$initialize(void);
10215 #pragma extern_model strict_refdef
10217 int lib_init_ref = (int) lib$initialize;
10220 #pragma extern_model restore