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.
60 #define VMS_MAXRSS NAM$C_MAXRSS
65 #define VMS_MAXRSS NAML$C_MAXRSS
70 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
71 int decc$feature_get_index(const char *name);
72 char* decc$feature_get_name(int index);
73 int decc$feature_get_value(int index, int mode);
74 int decc$feature_set_value(int index, int mode, int value);
80 #if __CRTL_VER >= 70300000
82 static int set_feature_default(const char *name, int value)
87 index = decc$feature_get_index(name);
89 status = decc$feature_set_value(index, 1, value);
90 if (index == -1 || (status == -1)) {
94 status = decc$feature_get_value(index, 1);
95 if (status != value) {
104 /* Older versions of ssdef.h don't have these */
105 #ifndef SS$_INVFILFOROP
106 # define SS$_INVFILFOROP 3930
108 #ifndef SS$_NOSUCHOBJECT
109 # define SS$_NOSUCHOBJECT 2696
112 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
113 #define PERLIO_NOT_STDIO 0
115 /* Don't replace system definitions of vfork, getenv, and stat,
116 * code below needs to get to the underlying CRTL routines. */
117 #define DONT_MASK_RTL_CALLS
121 /* Anticipating future expansion in lexical warnings . . . */
122 #ifndef WARN_INTERNAL
123 # define WARN_INTERNAL WARN_MISC
126 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
127 # define RTL_USES_UTC 1
131 /* gcc's header files don't #define direct access macros
132 * corresponding to VAXC's variant structs */
134 # define uic$v_format uic$r_uic_form.uic$v_format
135 # define uic$v_group uic$r_uic_form.uic$v_group
136 # define uic$v_member uic$r_uic_form.uic$v_member
137 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
138 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
139 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
140 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
143 #if defined(NEED_AN_H_ERRNO)
148 #pragma message disable pragma
149 #pragma member_alignment save
150 #pragma nomember_alignment longword
152 #pragma message disable misalgndmem
155 unsigned short int buflen;
156 unsigned short int itmcode;
158 unsigned short int *retlen;
161 #pragma message restore
162 #pragma member_alignment restore
165 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
166 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
167 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
168 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
169 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
170 #define do_vms_realpath(a,b) mp_do_vms_realpath(aTHX_ a,b)
171 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
172 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
173 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
174 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
175 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
177 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
178 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
179 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
180 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
182 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
183 #define PERL_LNM_MAX_ALLOWED_INDEX 127
185 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
186 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
189 #define PERL_LNM_MAX_ITER 10
191 #define MAX_DCL_SYMBOL 255 /* well, what *we* can set, at least*/
192 #define MAX_DCL_LINE_LENGTH (4*MAX_DCL_SYMBOL-4)
194 static char *__mystrtolower(char *str)
196 if (str) for (; *str; ++str) *str= tolower(*str);
200 static struct dsc$descriptor_s fildevdsc =
201 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
202 static struct dsc$descriptor_s crtlenvdsc =
203 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
204 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
205 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
206 static struct dsc$descriptor_s **env_tables = defenv;
207 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
209 /* True if we shouldn't treat barewords as logicals during directory */
211 static int no_translate_barewords;
214 static int tz_updated = 1;
217 /* DECC Features that may need to affect how Perl interprets
218 * displays filename information
220 static int decc_disable_to_vms_logname_translation = 1;
221 static int decc_disable_posix_root = 1;
222 int decc_efs_case_preserve = 0;
223 static int decc_efs_charset = 0;
224 static int decc_filename_unix_no_version = 0;
225 static int decc_filename_unix_only = 0;
226 int decc_filename_unix_report = 0;
227 int decc_posix_compliant_pathnames = 0;
228 int decc_readdir_dropdotnotype = 0;
229 static int vms_process_case_tolerant = 1;
231 /* Is this a UNIX file specification?
232 * No longer a simple check with EFS file specs
233 * For now, not a full check, but need to
234 * handle POSIX ^UP^ specifications
235 * Fixing to handle ^/ cases would require
236 * changes to many other conversion routines.
239 static is_unix_filespec(const char *path)
245 if (strncmp(path,"\"^UP^",5) != 0) {
246 pch1 = strchr(path, '/');
251 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
252 if (decc_filename_unix_report || decc_filename_unix_only) {
253 if (strcmp(path,".") == 0)
263 * Routine to retrieve the maximum equivalence index for an input
264 * logical name. Some calls to this routine have no knowledge if
265 * the variable is a logical or not. So on error we return a max
268 /*{{{int my_maxidx(const char *lnm) */
270 my_maxidx(const char *lnm)
274 int attr = LNM$M_CASE_BLIND;
275 struct dsc$descriptor lnmdsc;
276 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
279 lnmdsc.dsc$w_length = strlen(lnm);
280 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
281 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
282 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
284 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
285 if ((status & 1) == 0)
292 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
294 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
295 struct dsc$descriptor_s **tabvec, unsigned long int flags)
298 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
299 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
300 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
302 unsigned char acmode;
303 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
304 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
305 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
306 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
308 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
309 #if defined(PERL_IMPLICIT_CONTEXT)
312 aTHX = PERL_GET_INTERP;
318 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
319 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
321 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
322 *cp2 = _toupper(*cp1);
323 if (cp1 - lnm > LNM$C_NAMLENGTH) {
324 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
328 lnmdsc.dsc$w_length = cp1 - lnm;
329 lnmdsc.dsc$a_pointer = uplnm;
330 uplnm[lnmdsc.dsc$w_length] = '\0';
331 secure = flags & PERL__TRNENV_SECURE;
332 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
333 if (!tabvec || !*tabvec) tabvec = env_tables;
335 for (curtab = 0; tabvec[curtab]; curtab++) {
336 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
337 if (!ivenv && !secure) {
342 Perl_warn(aTHX_ "Can't read CRTL environ\n");
345 retsts = SS$_NOLOGNAM;
346 for (i = 0; environ[i]; i++) {
347 if ((eq = strchr(environ[i],'=')) &&
348 lnmdsc.dsc$w_length == (eq - environ[i]) &&
349 !strncmp(environ[i],uplnm,eq - environ[i])) {
351 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
352 if (!eqvlen) continue;
357 if (retsts != SS$_NOLOGNAM) break;
360 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
361 !str$case_blind_compare(&tmpdsc,&clisym)) {
362 if (!ivsym && !secure) {
363 unsigned short int deflen = LNM$C_NAMLENGTH;
364 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
365 /* dynamic dsc to accomodate possible long value */
366 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
367 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
370 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
372 /* Special hack--we might be called before the interpreter's */
373 /* fully initialized, in which case either thr or PL_curcop */
374 /* might be bogus. We have to check, since ckWARN needs them */
375 /* both to be valid if running threaded */
376 if (ckWARN(WARN_MISC)) {
377 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
380 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
382 _ckvmssts(lib$sfree1_dd(&eqvdsc));
383 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
384 if (retsts == LIB$_NOSUCHSYM) continue;
389 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
390 midx = my_maxidx(lnm);
391 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
392 lnmlst[1].bufadr = cp2;
394 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
395 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
396 if (retsts == SS$_NOLOGNAM) break;
397 /* PPFs have a prefix */
400 *((int *)uplnm) == *((int *)"SYS$") &&
402 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
403 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
404 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
405 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
406 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
407 memcpy(eqv,eqv+4,eqvlen-4);
413 if ((retsts == SS$_IVLOGNAM) ||
414 (retsts == SS$_NOLOGNAM)) { continue; }
417 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
418 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
419 if (retsts == SS$_NOLOGNAM) continue;
422 eqvlen = strlen(eqv);
426 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
427 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
428 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
429 retsts == SS$_NOLOGNAM) {
430 set_errno(EINVAL); set_vaxc_errno(retsts);
432 else _ckvmssts(retsts);
434 } /* end of vmstrnenv */
437 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
438 /* Define as a function so we can access statics. */
439 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
441 return vmstrnenv(lnm,eqv,idx,fildev,
442 #ifdef SECURE_INTERNAL_GETENV
443 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
452 * Note: Uses Perl temp to store result so char * can be returned to
453 * caller; this pointer will be invalidated at next Perl statement
455 * We define this as a function rather than a macro in terms of my_getenv_len()
456 * so that it'll work when PL_curinterp is undefined (and we therefore can't
459 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
461 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
464 static char *__my_getenv_eqv = NULL;
465 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
466 unsigned long int idx = 0;
467 int trnsuccess, success, secure, saverr, savvmserr;
471 midx = my_maxidx(lnm) + 1;
473 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
474 /* Set up a temporary buffer for the return value; Perl will
475 * clean it up at the next statement transition */
476 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
477 if (!tmpsv) return NULL;
481 /* Assume no interpreter ==> single thread */
482 if (__my_getenv_eqv != NULL) {
483 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
486 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
488 eqv = __my_getenv_eqv;
491 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
492 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
493 getcwd(eqv,LNM$C_NAMLENGTH);
497 /* Impose security constraints only if tainting */
499 /* Impose security constraints only if tainting */
500 secure = PL_curinterp ? PL_tainting : will_taint;
501 saverr = errno; savvmserr = vaxc$errno;
508 #ifdef SECURE_INTERNAL_GETENV
509 secure ? PERL__TRNENV_SECURE : 0
515 /* For the getenv interface we combine all the equivalence names
516 * of a search list logical into one value to acquire a maximum
517 * value length of 255*128 (assuming %ENV is using logicals).
519 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
521 /* If the name contains a semicolon-delimited index, parse it
522 * off and make sure we only retrieve the equivalence name for
524 if ((cp2 = strchr(lnm,';')) != NULL) {
526 uplnm[cp2-lnm] = '\0';
527 idx = strtoul(cp2+1,NULL,0);
529 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
532 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
534 /* Discard NOLOGNAM on internal calls since we're often looking
535 * for an optional name, and this "error" often shows up as the
536 * (bogus) exit status for a die() call later on. */
537 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
538 return success ? eqv : Nullch;
541 } /* end of my_getenv() */
545 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
547 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
551 unsigned long idx = 0;
553 static char *__my_getenv_len_eqv = NULL;
554 int secure, saverr, savvmserr;
557 midx = my_maxidx(lnm) + 1;
559 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
560 /* Set up a temporary buffer for the return value; Perl will
561 * clean it up at the next statement transition */
562 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
563 if (!tmpsv) return NULL;
567 /* Assume no interpreter ==> single thread */
568 if (__my_getenv_len_eqv != NULL) {
569 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
572 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
574 buf = __my_getenv_len_eqv;
577 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
578 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
581 getcwd(buf,LNM$C_NAMLENGTH);
584 /* Get rid of "000000/ in rooted filespecs */
586 zeros = strstr(buf, "/000000/");
589 mlen = *len - (zeros - buf) - 7;
590 memmove(zeros, &zeros[7], mlen);
599 /* Impose security constraints only if tainting */
600 secure = PL_curinterp ? PL_tainting : will_taint;
601 saverr = errno; savvmserr = vaxc$errno;
608 #ifdef SECURE_INTERNAL_GETENV
609 secure ? PERL__TRNENV_SECURE : 0
615 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
617 if ((cp2 = strchr(lnm,';')) != NULL) {
620 idx = strtoul(cp2+1,NULL,0);
622 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
625 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
627 /* Get rid of "000000/ in rooted filespecs */
630 zeros = strstr(buf, "/000000/");
633 mlen = *len - (zeros - buf) - 7;
634 memmove(zeros, &zeros[7], mlen);
640 /* Discard NOLOGNAM on internal calls since we're often looking
641 * for an optional name, and this "error" often shows up as the
642 * (bogus) exit status for a die() call later on. */
643 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
644 return *len ? buf : Nullch;
647 } /* end of my_getenv_len() */
650 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
652 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
654 /*{{{ void prime_env_iter() */
657 /* Fill the %ENV associative array with all logical names we can
658 * find, in preparation for iterating over it.
661 static int primed = 0;
662 HV *seenhv = NULL, *envhv;
664 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
665 unsigned short int chan;
666 #ifndef CLI$M_TRUSTED
667 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
669 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
670 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
672 bool have_sym = FALSE, have_lnm = FALSE;
673 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
674 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
675 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
676 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
677 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
678 #if defined(PERL_IMPLICIT_CONTEXT)
681 #if defined(USE_ITHREADS)
682 static perl_mutex primenv_mutex;
683 MUTEX_INIT(&primenv_mutex);
686 #if defined(PERL_IMPLICIT_CONTEXT)
687 /* We jump through these hoops because we can be called at */
688 /* platform-specific initialization time, which is before anything is */
689 /* set up--we can't even do a plain dTHX since that relies on the */
690 /* interpreter structure to be initialized */
692 aTHX = PERL_GET_INTERP;
698 if (primed || !PL_envgv) return;
699 MUTEX_LOCK(&primenv_mutex);
700 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
701 envhv = GvHVn(PL_envgv);
702 /* Perform a dummy fetch as an lval to insure that the hash table is
703 * set up. Otherwise, the hv_store() will turn into a nullop. */
704 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
706 for (i = 0; env_tables[i]; i++) {
707 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
708 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
709 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
711 if (have_sym || have_lnm) {
712 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
713 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
714 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
715 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
718 for (i--; i >= 0; i--) {
719 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
722 for (j = 0; environ[j]; j++) {
723 if (!(start = strchr(environ[j],'='))) {
724 if (ckWARN(WARN_INTERNAL))
725 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
729 sv = newSVpv(start,0);
731 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
736 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
737 !str$case_blind_compare(&tmpdsc,&clisym)) {
738 strcpy(cmd,"Show Symbol/Global *");
739 cmddsc.dsc$w_length = 20;
740 if (env_tables[i]->dsc$w_length == 12 &&
741 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
742 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
743 flags = defflags | CLI$M_NOLOGNAM;
746 strcpy(cmd,"Show Logical *");
747 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
748 strcat(cmd," /Table=");
749 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
750 cmddsc.dsc$w_length = strlen(cmd);
752 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
753 flags = defflags | CLI$M_NOCLISYM;
756 /* Create a new subprocess to execute each command, to exclude the
757 * remote possibility that someone could subvert a mbx or file used
758 * to write multiple commands to a single subprocess.
761 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
762 0,&riseandshine,0,0,&clidsc,&clitabdsc);
763 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
764 defflags &= ~CLI$M_TRUSTED;
765 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
767 if (!buf) Newx(buf,mbxbufsiz + 1,char);
768 if (seenhv) SvREFCNT_dec(seenhv);
771 char *cp1, *cp2, *key;
772 unsigned long int sts, iosb[2], retlen, keylen;
775 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
776 if (sts & 1) sts = iosb[0] & 0xffff;
777 if (sts == SS$_ENDOFFILE) {
779 while (substs == 0) { sys$hiber(); wakect++;}
780 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
785 retlen = iosb[0] >> 16;
786 if (!retlen) continue; /* blank line */
788 if (iosb[1] != subpid) {
790 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
794 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
795 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
797 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
798 if (*cp1 == '(' || /* Logical name table name */
799 *cp1 == '=' /* Next eqv of searchlist */) continue;
800 if (*cp1 == '"') cp1++;
801 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
802 key = cp1; keylen = cp2 - cp1;
803 if (keylen && hv_exists(seenhv,key,keylen)) continue;
804 while (*cp2 && *cp2 != '=') cp2++;
805 while (*cp2 && *cp2 == '=') cp2++;
806 while (*cp2 && *cp2 == ' ') cp2++;
807 if (*cp2 == '"') { /* String translation; may embed "" */
808 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
809 cp2++; cp1--; /* Skip "" surrounding translation */
811 else { /* Numeric translation */
812 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
813 cp1--; /* stop on last non-space char */
815 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
816 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
819 PERL_HASH(hash,key,keylen);
821 if (cp1 == cp2 && *cp2 == '.') {
822 /* A single dot usually means an unprintable character, such as a null
823 * to indicate a zero-length value. Get the actual value to make sure.
825 char lnm[LNM$C_NAMLENGTH+1];
826 char eqv[LNM$C_NAMLENGTH+1];
827 strncpy(lnm, key, keylen);
828 int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
829 sv = newSVpvn(eqv, strlen(eqv));
832 sv = newSVpvn(cp2,cp1 - cp2 + 1);
836 hv_store(envhv,key,keylen,sv,hash);
837 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
839 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
840 /* get the PPFs for this process, not the subprocess */
841 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
842 char eqv[LNM$C_NAMLENGTH+1];
844 for (i = 0; ppfs[i]; i++) {
845 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
846 sv = newSVpv(eqv,trnlen);
848 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
853 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
854 if (buf) Safefree(buf);
855 if (seenhv) SvREFCNT_dec(seenhv);
856 MUTEX_UNLOCK(&primenv_mutex);
859 } /* end of prime_env_iter */
863 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
864 /* Define or delete an element in the same "environment" as
865 * vmstrnenv(). If an element is to be deleted, it's removed from
866 * the first place it's found. If it's to be set, it's set in the
867 * place designated by the first element of the table vector.
868 * Like setenv() returns 0 for success, non-zero on error.
871 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
874 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
875 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
877 unsigned long int retsts, usermode = PSL$C_USER;
878 struct itmlst_3 *ile, *ilist;
879 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
880 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
881 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
882 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
883 $DESCRIPTOR(local,"_LOCAL");
886 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
890 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
891 *cp2 = _toupper(*cp1);
892 if (cp1 - lnm > LNM$C_NAMLENGTH) {
893 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
897 lnmdsc.dsc$w_length = cp1 - lnm;
898 if (!tabvec || !*tabvec) tabvec = env_tables;
900 if (!eqv) { /* we're deleting n element */
901 for (curtab = 0; tabvec[curtab]; curtab++) {
902 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
904 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
905 if ((cp1 = strchr(environ[i],'=')) &&
906 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
907 !strncmp(environ[i],lnm,cp1 - environ[i])) {
909 return setenv(lnm,"",1) ? vaxc$errno : 0;
912 ivenv = 1; retsts = SS$_NOLOGNAM;
914 if (ckWARN(WARN_INTERNAL))
915 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
916 ivenv = 1; retsts = SS$_NOSUCHPGM;
922 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
923 !str$case_blind_compare(&tmpdsc,&clisym)) {
924 unsigned int symtype;
925 if (tabvec[curtab]->dsc$w_length == 12 &&
926 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
927 !str$case_blind_compare(&tmpdsc,&local))
928 symtype = LIB$K_CLI_LOCAL_SYM;
929 else symtype = LIB$K_CLI_GLOBAL_SYM;
930 retsts = lib$delete_symbol(&lnmdsc,&symtype);
931 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
932 if (retsts == LIB$_NOSUCHSYM) continue;
936 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
937 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
938 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
939 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
940 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
944 else { /* we're defining a value */
945 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
947 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
949 if (ckWARN(WARN_INTERNAL))
950 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
951 retsts = SS$_NOSUCHPGM;
955 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
956 eqvdsc.dsc$w_length = strlen(eqv);
957 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
958 !str$case_blind_compare(&tmpdsc,&clisym)) {
959 unsigned int symtype;
960 if (tabvec[0]->dsc$w_length == 12 &&
961 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
962 !str$case_blind_compare(&tmpdsc,&local))
963 symtype = LIB$K_CLI_LOCAL_SYM;
964 else symtype = LIB$K_CLI_GLOBAL_SYM;
965 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
968 if (!*eqv) eqvdsc.dsc$w_length = 1;
969 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
971 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
972 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
973 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
974 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
975 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
976 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
979 Newx(ilist,nseg+1,struct itmlst_3);
982 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
985 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
987 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
988 ile->itmcode = LNM$_STRING;
991 ile->buflen = strlen(c);
992 /* in case we are truncating one that's too long */
993 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
996 ile->buflen = LNM$C_NAMLENGTH;
1000 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1004 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1009 if (!(retsts & 1)) {
1011 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1012 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1013 set_errno(EVMSERR); break;
1014 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1015 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1016 set_errno(EINVAL); break;
1023 set_vaxc_errno(retsts);
1024 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1027 /* We reset error values on success because Perl does an hv_fetch()
1028 * before each hv_store(), and if the thing we're setting didn't
1029 * previously exist, we've got a leftover error message. (Of course,
1030 * this fails in the face of
1031 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1032 * in that the error reported in $! isn't spurious,
1033 * but it's right more often than not.)
1035 set_errno(0); set_vaxc_errno(retsts);
1039 } /* end of vmssetenv() */
1042 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1043 /* This has to be a function since there's a prototype for it in proto.h */
1045 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1048 int len = strlen(lnm);
1052 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1053 if (!strcmp(uplnm,"DEFAULT")) {
1054 if (eqv && *eqv) chdir(eqv);
1058 #ifndef RTL_USES_UTC
1059 if (len == 6 || len == 2) {
1062 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1064 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1065 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1069 (void) vmssetenv(lnm,eqv,NULL);
1073 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1075 * sets a user-mode logical in the process logical name table
1076 * used for redirection of sys$error
1079 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1081 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1082 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1083 unsigned long int iss, attr = LNM$M_CONFINE;
1084 unsigned char acmode = PSL$C_USER;
1085 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1087 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1088 d_name.dsc$w_length = strlen(name);
1090 lnmlst[0].buflen = strlen(eqv);
1091 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1093 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1094 if (!(iss&1)) lib$signal(iss);
1099 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1100 /* my_crypt - VMS password hashing
1101 * my_crypt() provides an interface compatible with the Unix crypt()
1102 * C library function, and uses sys$hash_password() to perform VMS
1103 * password hashing. The quadword hashed password value is returned
1104 * as a NUL-terminated 8 character string. my_crypt() does not change
1105 * the case of its string arguments; in order to match the behavior
1106 * of LOGINOUT et al., alphabetic characters in both arguments must
1107 * be upcased by the caller.
1110 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1112 # ifndef UAI$C_PREFERRED_ALGORITHM
1113 # define UAI$C_PREFERRED_ALGORITHM 127
1115 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1116 unsigned short int salt = 0;
1117 unsigned long int sts;
1119 unsigned short int dsc$w_length;
1120 unsigned char dsc$b_type;
1121 unsigned char dsc$b_class;
1122 const char * dsc$a_pointer;
1123 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1124 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1125 struct itmlst_3 uailst[3] = {
1126 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1127 { sizeof salt, UAI$_SALT, &salt, 0},
1128 { 0, 0, NULL, NULL}};
1129 static char hash[9];
1131 usrdsc.dsc$w_length = strlen(usrname);
1132 usrdsc.dsc$a_pointer = usrname;
1133 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1135 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1139 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1144 set_vaxc_errno(sts);
1145 if (sts != RMS$_RNF) return NULL;
1148 txtdsc.dsc$w_length = strlen(textpasswd);
1149 txtdsc.dsc$a_pointer = textpasswd;
1150 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1151 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1154 return (char *) hash;
1156 } /* end of my_crypt() */
1160 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1161 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1162 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1164 /*{{{int do_rmdir(char *name)*/
1166 Perl_do_rmdir(pTHX_ const char *name)
1168 char dirfile[NAM$C_MAXRSS+1];
1172 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1173 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1174 else retval = kill_file(dirfile);
1177 } /* end of do_rmdir */
1181 * Delete any file to which user has control access, regardless of whether
1182 * delete access is explicitly allowed.
1183 * Limitations: User must have write access to parent directory.
1184 * Does not block signals or ASTs; if interrupted in midstream
1185 * may leave file with an altered ACL.
1188 /*{{{int kill_file(char *name)*/
1190 Perl_kill_file(pTHX_ const char *name)
1192 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1193 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1194 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1195 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1197 unsigned char myace$b_length;
1198 unsigned char myace$b_type;
1199 unsigned short int myace$w_flags;
1200 unsigned long int myace$l_access;
1201 unsigned long int myace$l_ident;
1202 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1203 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1204 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1206 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1207 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1208 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1209 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1210 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1211 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1213 /* Expand the input spec using RMS, since the CRTL remove() and
1214 * system services won't do this by themselves, so we may miss
1215 * a file "hiding" behind a logical name or search list. */
1216 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1217 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1218 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1219 /* If not, can changing protections help? */
1220 if (vaxc$errno != RMS$_PRV) return -1;
1222 /* No, so we get our own UIC to use as a rights identifier,
1223 * and the insert an ACE at the head of the ACL which allows us
1224 * to delete the file.
1226 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1227 fildsc.dsc$w_length = strlen(rspec);
1228 fildsc.dsc$a_pointer = rspec;
1230 newace.myace$l_ident = oldace.myace$l_ident;
1231 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1233 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1234 set_errno(ENOENT); break;
1236 set_errno(ENOTDIR); break;
1238 set_errno(ENODEV); break;
1239 case RMS$_SYN: case SS$_INVFILFOROP:
1240 set_errno(EINVAL); break;
1242 set_errno(EACCES); break;
1246 set_vaxc_errno(aclsts);
1249 /* Grab any existing ACEs with this identifier in case we fail */
1250 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1251 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1252 || fndsts == SS$_NOMOREACE ) {
1253 /* Add the new ACE . . . */
1254 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1256 if ((rmsts = remove(name))) {
1257 /* We blew it - dir with files in it, no write priv for
1258 * parent directory, etc. Put things back the way they were. */
1259 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1262 addlst[0].bufadr = &oldace;
1263 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1270 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1271 /* We just deleted it, so of course it's not there. Some versions of
1272 * VMS seem to return success on the unlock operation anyhow (after all
1273 * the unlock is successful), but others don't.
1275 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1276 if (aclsts & 1) aclsts = fndsts;
1277 if (!(aclsts & 1)) {
1279 set_vaxc_errno(aclsts);
1285 } /* end of kill_file() */
1289 /*{{{int my_mkdir(char *,Mode_t)*/
1291 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1293 STRLEN dirlen = strlen(dir);
1295 /* zero length string sometimes gives ACCVIO */
1296 if (dirlen == 0) return -1;
1298 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1299 * null file name/type. However, it's commonplace under Unix,
1300 * so we'll allow it for a gain in portability.
1302 if (dir[dirlen-1] == '/') {
1303 char *newdir = savepvn(dir,dirlen-1);
1304 int ret = mkdir(newdir,mode);
1308 else return mkdir(dir,mode);
1309 } /* end of my_mkdir */
1312 /*{{{int my_chdir(char *)*/
1314 Perl_my_chdir(pTHX_ const char *dir)
1316 STRLEN dirlen = strlen(dir);
1318 /* zero length string sometimes gives ACCVIO */
1319 if (dirlen == 0) return -1;
1322 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1323 * This does not work if DECC$EFS_CHARSET is active. Hack it here
1324 * so that existing scripts do not need to be changed.
1327 while ((dirlen > 0) && (*dir1 == ' ')) {
1332 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1334 * null file name/type. However, it's commonplace under Unix,
1335 * so we'll allow it for a gain in portability.
1337 * - Preview- '/' will be valid soon on VMS
1339 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1340 char *newdir = savepvn(dir,dirlen-1);
1341 int ret = chdir(newdir);
1345 else return chdir(dir);
1346 } /* end of my_chdir */
1350 /*{{{FILE *my_tmpfile()*/
1357 if ((fp = tmpfile())) return fp;
1359 Newx(cp,L_tmpnam+24,char);
1360 strcpy(cp,"Sys$Scratch:");
1361 tmpnam(cp+strlen(cp));
1362 strcat(cp,".Perltmp");
1363 fp = fopen(cp,"w+","fop=dlt");
1370 #ifndef HOMEGROWN_POSIX_SIGNALS
1372 * The C RTL's sigaction fails to check for invalid signal numbers so we
1373 * help it out a bit. The docs are correct, but the actual routine doesn't
1374 * do what the docs say it will.
1376 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1378 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1379 struct sigaction* oact)
1381 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1382 SETERRNO(EINVAL, SS$_INVARG);
1385 return sigaction(sig, act, oact);
1390 #ifdef KILL_BY_SIGPRC
1391 #include <errnodef.h>
1393 /* We implement our own kill() using the undocumented system service
1394 sys$sigprc for one of two reasons:
1396 1.) If the kill() in an older CRTL uses sys$forcex, causing the
1397 target process to do a sys$exit, which usually can't be handled
1398 gracefully...certainly not by Perl and the %SIG{} mechanism.
1400 2.) If the kill() in the CRTL can't be called from a signal
1401 handler without disappearing into the ether, i.e., the signal
1402 it purportedly sends is never trapped. Still true as of VMS 7.3.
1404 sys$sigprc has the same parameters as sys$forcex, but throws an exception
1405 in the target process rather than calling sys$exit.
1407 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1408 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1409 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1410 with condition codes C$_SIG0+nsig*8, catching the exception on the
1411 target process and resignaling with appropriate arguments.
1413 But we don't have that VMS 7.0+ exception handler, so if you
1414 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1416 Also note that SIGTERM is listed in the docs as being "unimplemented",
1417 yet always seems to be signaled with a VMS condition code of 4 (and
1418 correctly handled for that code). So we hardwire it in.
1420 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1421 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1422 than signalling with an unrecognized (and unhandled by CRTL) code.
1425 #define _MY_SIG_MAX 17
1428 Perl_sig_to_vmscondition(int sig)
1430 static unsigned int sig_code[_MY_SIG_MAX+1] =
1433 SS$_HANGUP, /* 1 SIGHUP */
1434 SS$_CONTROLC, /* 2 SIGINT */
1435 SS$_CONTROLY, /* 3 SIGQUIT */
1436 SS$_RADRMOD, /* 4 SIGILL */
1437 SS$_BREAK, /* 5 SIGTRAP */
1438 SS$_OPCCUS, /* 6 SIGABRT */
1439 SS$_COMPAT, /* 7 SIGEMT */
1441 SS$_FLTOVF, /* 8 SIGFPE VAX */
1443 SS$_HPARITH, /* 8 SIGFPE AXP */
1445 SS$_ABORT, /* 9 SIGKILL */
1446 SS$_ACCVIO, /* 10 SIGBUS */
1447 SS$_ACCVIO, /* 11 SIGSEGV */
1448 SS$_BADPARAM, /* 12 SIGSYS */
1449 SS$_NOMBX, /* 13 SIGPIPE */
1450 SS$_ASTFLT, /* 14 SIGALRM */
1456 #if __VMS_VER >= 60200000
1457 static int initted = 0;
1460 sig_code[16] = C$_SIGUSR1;
1461 sig_code[17] = C$_SIGUSR2;
1465 if (sig < _SIG_MIN) return 0;
1466 if (sig > _MY_SIG_MAX) return 0;
1467 return sig_code[sig];
1471 Perl_my_kill(int pid, int sig)
1476 int sys$sigprc(unsigned int *pidadr,
1477 struct dsc$descriptor_s *prcname,
1480 code = Perl_sig_to_vmscondition(sig);
1482 if (!pid || !code) {
1486 iss = sys$sigprc((unsigned int *)&pid,0,code);
1487 if (iss&1) return 0;
1491 set_errno(EPERM); break;
1493 case SS$_NOSUCHNODE:
1494 case SS$_UNREACHABLE:
1495 set_errno(ESRCH); break;
1497 set_errno(ENOMEM); break;
1502 set_vaxc_errno(iss);
1508 /* Routine to convert a VMS status code to a UNIX status code.
1509 ** More tricky than it appears because of conflicting conventions with
1512 ** VMS status codes are a bit mask, with the least significant bit set for
1515 ** Special UNIX status of EVMSERR indicates that no translation is currently
1516 ** available, and programs should check the VMS status code.
1518 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
1522 #ifndef C_FACILITY_NO
1523 #define C_FACILITY_NO 0x350000
1526 #define DCL_IVVERB 0x38090
1529 int vms_status_to_unix(int vms_status)
1537 /* Assume the best or the worst */
1538 if (vms_status & STS$M_SUCCESS)
1541 unix_status = EVMSERR;
1543 msg_status = vms_status & ~STS$M_CONTROL;
1545 facility = vms_status & STS$M_FAC_NO;
1546 fac_sp = vms_status & STS$M_FAC_SP;
1547 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
1549 if ((facility == 0) || (fac_sp == 0)) {
1555 unix_status = EFAULT;
1562 case SS$_INVFILFOROP:
1566 unix_status = EINVAL;
1571 unix_status = EACCES;
1573 case SS$_DEVICEFULL:
1574 unix_status = ENOSPC;
1577 unix_status = ENODEV;
1579 case SS$_NOSUCHFILE:
1580 case SS$_NOSUCHOBJECT:
1581 unix_status = ENOENT;
1584 unix_status = EINTR;
1587 unix_status = E2BIG;
1590 unix_status = ENOMEM;
1593 unix_status = EPERM;
1595 case SS$_NOSUCHNODE:
1596 case SS$_UNREACHABLE:
1597 unix_status = ESRCH;
1600 unix_status = ECHILD;
1603 if ((facility == 0) && (msg_no < 8)) {
1604 /* These are not real VMS status codes so assume that they are
1605 ** already UNIX status codes
1607 unix_status = msg_no;
1613 /* Translate a POSIX exit code to a UNIX exit code */
1614 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
1615 unix_status = (msg_no & 0x0FF0) >> 3;
1618 switch(msg_status) {
1619 /* case RMS$_EOF: */ /* End of File */
1620 case RMS$_FNF: /* File Not Found */
1621 case RMS$_DNF: /* Dir Not Found */
1622 unix_status = ENOENT;
1624 case RMS$_RNF: /* Record Not Found */
1625 unix_status = ESRCH;
1628 unix_status = ENOTDIR;
1631 unix_status = ENODEV;
1635 case LIB$_INVSTRDES:
1637 case LIB$_NOSUCHSYM:
1638 case LIB$_INVSYMNAM:
1640 unix_status = EINVAL;
1646 unix_status = E2BIG;
1648 case RMS$_PRV: /* No privilege */
1649 case RMS$_ACC: /* ACP file access failed */
1650 case RMS$_WLK: /* Device write locked */
1651 unix_status = EACCES;
1653 /* case RMS$_NMF: */ /* No more files */
1663 /* default piping mailbox size */
1664 #define PERL_BUFSIZ 512
1668 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1670 unsigned long int mbxbufsiz;
1671 static unsigned long int syssize = 0;
1672 unsigned long int dviitm = DVI$_DEVNAM;
1673 char csize[LNM$C_NAMLENGTH+1];
1677 unsigned long syiitm = SYI$_MAXBUF;
1679 * Get the SYSGEN parameter MAXBUF
1681 * If the logical 'PERL_MBX_SIZE' is defined
1682 * use the value of the logical instead of PERL_BUFSIZ, but
1683 * keep the size between 128 and MAXBUF.
1686 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1689 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1690 mbxbufsiz = atoi(csize);
1692 mbxbufsiz = PERL_BUFSIZ;
1694 if (mbxbufsiz < 128) mbxbufsiz = 128;
1695 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1697 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1699 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1700 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1702 } /* end of create_mbx() */
1705 /*{{{ my_popen and my_pclose*/
1707 typedef struct _iosb IOSB;
1708 typedef struct _iosb* pIOSB;
1709 typedef struct _pipe Pipe;
1710 typedef struct _pipe* pPipe;
1711 typedef struct pipe_details Info;
1712 typedef struct pipe_details* pInfo;
1713 typedef struct _srqp RQE;
1714 typedef struct _srqp* pRQE;
1715 typedef struct _tochildbuf CBuf;
1716 typedef struct _tochildbuf* pCBuf;
1719 unsigned short status;
1720 unsigned short count;
1721 unsigned long dvispec;
1724 #pragma member_alignment save
1725 #pragma nomember_alignment quadword
1726 struct _srqp { /* VMS self-relative queue entry */
1727 unsigned long qptr[2];
1729 #pragma member_alignment restore
1730 static RQE RQE_ZERO = {0,0};
1732 struct _tochildbuf {
1735 unsigned short size;
1743 unsigned short chan_in;
1744 unsigned short chan_out;
1746 unsigned int bufsize;
1758 #if defined(PERL_IMPLICIT_CONTEXT)
1759 void *thx; /* Either a thread or an interpreter */
1760 /* pointer, depending on how we're built */
1768 PerlIO *fp; /* file pointer to pipe mailbox */
1769 int useFILE; /* using stdio, not perlio */
1770 int pid; /* PID of subprocess */
1771 int mode; /* == 'r' if pipe open for reading */
1772 int done; /* subprocess has completed */
1773 int waiting; /* waiting for completion/closure */
1774 int closing; /* my_pclose is closing this pipe */
1775 unsigned long completion; /* termination status of subprocess */
1776 pPipe in; /* pipe in to sub */
1777 pPipe out; /* pipe out of sub */
1778 pPipe err; /* pipe of sub's sys$error */
1779 int in_done; /* true when in pipe finished */
1784 struct exit_control_block
1786 struct exit_control_block *flink;
1787 unsigned long int (*exit_routine)();
1788 unsigned long int arg_count;
1789 unsigned long int *status_address;
1790 unsigned long int exit_status;
1793 typedef struct _closed_pipes Xpipe;
1794 typedef struct _closed_pipes* pXpipe;
1796 struct _closed_pipes {
1797 int pid; /* PID of subprocess */
1798 unsigned long completion; /* termination status of subprocess */
1800 #define NKEEPCLOSED 50
1801 static Xpipe closed_list[NKEEPCLOSED];
1802 static int closed_index = 0;
1803 static int closed_num = 0;
1805 #define RETRY_DELAY "0 ::0.20"
1806 #define MAX_RETRY 50
1808 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1809 static unsigned long mypid;
1810 static unsigned long delaytime[2];
1812 static pInfo open_pipes = NULL;
1813 static $DESCRIPTOR(nl_desc, "NL:");
1815 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
1819 static unsigned long int
1820 pipe_exit_routine(pTHX)
1823 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1824 int sts, did_stuff, need_eof, j;
1827 flush any pending i/o
1833 PerlIO_flush(info->fp); /* first, flush data */
1835 fflush((FILE *)info->fp);
1841 next we try sending an EOF...ignore if doesn't work, make sure we
1849 _ckvmssts(sys$setast(0));
1850 if (info->in && !info->in->shut_on_empty) {
1851 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1856 _ckvmssts(sys$setast(1));
1860 /* wait for EOF to have effect, up to ~ 30 sec [default] */
1862 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1867 _ckvmssts(sys$setast(0));
1868 if (info->waiting && info->done)
1870 nwait += info->waiting;
1871 _ckvmssts(sys$setast(1));
1881 _ckvmssts(sys$setast(0));
1882 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1883 sts = sys$forcex(&info->pid,0,&abort);
1884 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1887 _ckvmssts(sys$setast(1));
1891 /* again, wait for effect */
1893 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1898 _ckvmssts(sys$setast(0));
1899 if (info->waiting && info->done)
1901 nwait += info->waiting;
1902 _ckvmssts(sys$setast(1));
1911 _ckvmssts(sys$setast(0));
1912 if (!info->done) { /* We tried to be nice . . . */
1913 sts = sys$delprc(&info->pid,0);
1914 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1916 _ckvmssts(sys$setast(1));
1921 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1922 else if (!(sts & 1)) retsts = sts;
1927 static struct exit_control_block pipe_exitblock =
1928 {(struct exit_control_block *) 0,
1929 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1931 static void pipe_mbxtofd_ast(pPipe p);
1932 static void pipe_tochild1_ast(pPipe p);
1933 static void pipe_tochild2_ast(pPipe p);
1936 popen_completion_ast(pInfo info)
1938 pInfo i = open_pipes;
1943 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1944 closed_list[closed_index].pid = info->pid;
1945 closed_list[closed_index].completion = info->completion;
1947 if (closed_index == NKEEPCLOSED)
1952 if (i == info) break;
1955 if (!i) return; /* unlinked, probably freed too */
1960 Writing to subprocess ...
1961 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1963 chan_out may be waiting for "done" flag, or hung waiting
1964 for i/o completion to child...cancel the i/o. This will
1965 put it into "snarf mode" (done but no EOF yet) that discards
1968 Output from subprocess (stdout, stderr) needs to be flushed and
1969 shut down. We try sending an EOF, but if the mbx is full the pipe
1970 routine should still catch the "shut_on_empty" flag, telling it to
1971 use immediate-style reads so that "mbx empty" -> EOF.
1975 if (info->in && !info->in_done) { /* only for mode=w */
1976 if (info->in->shut_on_empty && info->in->need_wake) {
1977 info->in->need_wake = FALSE;
1978 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1980 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1984 if (info->out && !info->out_done) { /* were we also piping output? */
1985 info->out->shut_on_empty = TRUE;
1986 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1987 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1988 _ckvmssts_noperl(iss);
1991 if (info->err && !info->err_done) { /* we were piping stderr */
1992 info->err->shut_on_empty = TRUE;
1993 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1994 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1995 _ckvmssts_noperl(iss);
1997 _ckvmssts_noperl(sys$setef(pipe_ef));
2001 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2002 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2005 we actually differ from vmstrnenv since we use this to
2006 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2007 are pointing to the same thing
2010 static unsigned short
2011 popen_translate(pTHX_ char *logical, char *result)
2014 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2015 $DESCRIPTOR(d_log,"");
2017 unsigned short length;
2018 unsigned short code;
2020 unsigned short *retlenaddr;
2022 unsigned short l, ifi;
2024 d_log.dsc$a_pointer = logical;
2025 d_log.dsc$w_length = strlen(logical);
2027 itmlst[0].code = LNM$_STRING;
2028 itmlst[0].length = 255;
2029 itmlst[0].buffer_addr = result;
2030 itmlst[0].retlenaddr = &l;
2033 itmlst[1].length = 0;
2034 itmlst[1].buffer_addr = 0;
2035 itmlst[1].retlenaddr = 0;
2037 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2038 if (iss == SS$_NOLOGNAM) {
2042 if (!(iss&1)) lib$signal(iss);
2045 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
2046 strip it off and return the ifi, if any
2049 if (result[0] == 0x1b && result[1] == 0x00) {
2050 memcpy(&ifi,result+2,2);
2051 strcpy(result,result+4);
2053 return ifi; /* this is the RMS internal file id */
2056 static void pipe_infromchild_ast(pPipe p);
2059 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2060 inside an AST routine without worrying about reentrancy and which Perl
2061 memory allocator is being used.
2063 We read data and queue up the buffers, then spit them out one at a
2064 time to the output mailbox when the output mailbox is ready for one.
2067 #define INITIAL_TOCHILDQUEUE 2
2070 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2074 char mbx1[64], mbx2[64];
2075 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2076 DSC$K_CLASS_S, mbx1},
2077 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2078 DSC$K_CLASS_S, mbx2};
2079 unsigned int dviitm = DVI$_DEVBUFSIZ;
2084 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2085 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2086 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2089 p->shut_on_empty = FALSE;
2090 p->need_wake = FALSE;
2093 p->iosb.status = SS$_NORMAL;
2094 p->iosb2.status = SS$_NORMAL;
2100 #ifdef PERL_IMPLICIT_CONTEXT
2104 n = sizeof(CBuf) + p->bufsize;
2106 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2107 _ckvmssts(lib$get_vm(&n, &b));
2108 b->buf = (char *) b + sizeof(CBuf);
2109 _ckvmssts(lib$insqhi(b, &p->free));
2112 pipe_tochild2_ast(p);
2113 pipe_tochild1_ast(p);
2119 /* reads the MBX Perl is writing, and queues */
2122 pipe_tochild1_ast(pPipe p)
2125 int iss = p->iosb.status;
2126 int eof = (iss == SS$_ENDOFFILE);
2128 #ifdef PERL_IMPLICIT_CONTEXT
2134 p->shut_on_empty = TRUE;
2136 _ckvmssts(sys$dassgn(p->chan_in));
2142 b->size = p->iosb.count;
2143 _ckvmssts(sts = lib$insqhi(b, &p->wait));
2145 p->need_wake = FALSE;
2146 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2149 p->retry = 1; /* initial call */
2152 if (eof) { /* flush the free queue, return when done */
2153 int n = sizeof(CBuf) + p->bufsize;
2155 iss = lib$remqti(&p->free, &b);
2156 if (iss == LIB$_QUEWASEMP) return;
2158 _ckvmssts(lib$free_vm(&n, &b));
2162 iss = lib$remqti(&p->free, &b);
2163 if (iss == LIB$_QUEWASEMP) {
2164 int n = sizeof(CBuf) + p->bufsize;
2165 _ckvmssts(lib$get_vm(&n, &b));
2166 b->buf = (char *) b + sizeof(CBuf);
2172 iss = sys$qio(0,p->chan_in,
2173 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2175 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2176 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2181 /* writes queued buffers to output, waits for each to complete before
2185 pipe_tochild2_ast(pPipe p)
2188 int iss = p->iosb2.status;
2189 int n = sizeof(CBuf) + p->bufsize;
2190 int done = (p->info && p->info->done) ||
2191 iss == SS$_CANCEL || iss == SS$_ABORT;
2192 #if defined(PERL_IMPLICIT_CONTEXT)
2197 if (p->type) { /* type=1 has old buffer, dispose */
2198 if (p->shut_on_empty) {
2199 _ckvmssts(lib$free_vm(&n, &b));
2201 _ckvmssts(lib$insqhi(b, &p->free));
2206 iss = lib$remqti(&p->wait, &b);
2207 if (iss == LIB$_QUEWASEMP) {
2208 if (p->shut_on_empty) {
2210 _ckvmssts(sys$dassgn(p->chan_out));
2211 *p->pipe_done = TRUE;
2212 _ckvmssts(sys$setef(pipe_ef));
2214 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2215 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2219 p->need_wake = TRUE;
2229 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2230 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2232 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2233 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2242 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2245 char mbx1[64], mbx2[64];
2246 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2247 DSC$K_CLASS_S, mbx1},
2248 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2249 DSC$K_CLASS_S, mbx2};
2250 unsigned int dviitm = DVI$_DEVBUFSIZ;
2253 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2254 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2256 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2257 Newx(p->buf, p->bufsize, char);
2258 p->shut_on_empty = FALSE;
2261 p->iosb.status = SS$_NORMAL;
2262 #if defined(PERL_IMPLICIT_CONTEXT)
2265 pipe_infromchild_ast(p);
2273 pipe_infromchild_ast(pPipe p)
2275 int iss = p->iosb.status;
2276 int eof = (iss == SS$_ENDOFFILE);
2277 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2278 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2279 #if defined(PERL_IMPLICIT_CONTEXT)
2283 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
2284 _ckvmssts(sys$dassgn(p->chan_out));
2289 input shutdown if EOF from self (done or shut_on_empty)
2290 output shutdown if closing flag set (my_pclose)
2291 send data/eof from child or eof from self
2292 otherwise, re-read (snarf of data from child)
2297 if (myeof && p->chan_in) { /* input shutdown */
2298 _ckvmssts(sys$dassgn(p->chan_in));
2303 if (myeof || kideof) { /* pass EOF to parent */
2304 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2305 pipe_infromchild_ast, p,
2308 } else if (eof) { /* eat EOF --- fall through to read*/
2310 } else { /* transmit data */
2311 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2312 pipe_infromchild_ast,p,
2313 p->buf, p->iosb.count, 0, 0, 0, 0));
2319 /* everything shut? flag as done */
2321 if (!p->chan_in && !p->chan_out) {
2322 *p->pipe_done = TRUE;
2323 _ckvmssts(sys$setef(pipe_ef));
2327 /* write completed (or read, if snarfing from child)
2328 if still have input active,
2329 queue read...immediate mode if shut_on_empty so we get EOF if empty
2331 check if Perl reading, generate EOFs as needed
2337 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2338 pipe_infromchild_ast,p,
2339 p->buf, p->bufsize, 0, 0, 0, 0);
2340 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2342 } else { /* send EOFs for extra reads */
2343 p->iosb.status = SS$_ENDOFFILE;
2344 p->iosb.dvispec = 0;
2345 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2347 pipe_infromchild_ast, p, 0, 0, 0, 0));
2353 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2357 unsigned long dviitm = DVI$_DEVBUFSIZ;
2359 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2360 DSC$K_CLASS_S, mbx};
2362 /* things like terminals and mbx's don't need this filter */
2363 if (fd && fstat(fd,&s) == 0) {
2364 unsigned long dviitm = DVI$_DEVCHAR, devchar;
2365 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2366 DSC$K_CLASS_S, s.st_dev};
2368 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2369 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
2370 strcpy(out, s.st_dev);
2376 p->fd_out = dup(fd);
2377 create_mbx(aTHX_ &p->chan_in, &d_mbx);
2378 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2379 Newx(p->buf, p->bufsize+1, char);
2380 p->shut_on_empty = FALSE;
2385 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2386 pipe_mbxtofd_ast, p,
2387 p->buf, p->bufsize, 0, 0, 0, 0));
2393 pipe_mbxtofd_ast(pPipe p)
2395 int iss = p->iosb.status;
2396 int done = p->info->done;
2398 int eof = (iss == SS$_ENDOFFILE);
2399 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2400 int err = !(iss&1) && !eof;
2401 #if defined(PERL_IMPLICIT_CONTEXT)
2405 if (done && myeof) { /* end piping */
2407 sys$dassgn(p->chan_in);
2408 *p->pipe_done = TRUE;
2409 _ckvmssts(sys$setef(pipe_ef));
2413 if (!err && !eof) { /* good data to send to file */
2414 p->buf[p->iosb.count] = '\n';
2415 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2418 if (p->retry < MAX_RETRY) {
2419 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2429 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2430 pipe_mbxtofd_ast, p,
2431 p->buf, p->bufsize, 0, 0, 0, 0);
2432 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2437 typedef struct _pipeloc PLOC;
2438 typedef struct _pipeloc* pPLOC;
2442 char dir[NAM$C_MAXRSS+1];
2444 static pPLOC head_PLOC = 0;
2447 free_pipelocs(pTHX_ void *head)
2450 pPLOC *pHead = (pPLOC *)head;
2462 store_pipelocs(pTHX)
2471 char temp[NAM$C_MAXRSS+1];
2475 free_pipelocs(aTHX_ &head_PLOC);
2477 /* the . directory from @INC comes last */
2480 p->next = head_PLOC;
2482 strcpy(p->dir,"./");
2484 /* get the directory from $^X */
2486 #ifdef PERL_IMPLICIT_CONTEXT
2487 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2489 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2491 strcpy(temp, PL_origargv[0]);
2492 x = strrchr(temp,']');
2495 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2497 p->next = head_PLOC;
2499 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2500 p->dir[NAM$C_MAXRSS] = '\0';
2504 /* reverse order of @INC entries, skip "." since entered above */
2506 #ifdef PERL_IMPLICIT_CONTEXT
2509 if (PL_incgv) av = GvAVn(PL_incgv);
2511 for (i = 0; av && i <= AvFILL(av); i++) {
2512 dirsv = *av_fetch(av,i,TRUE);
2514 if (SvROK(dirsv)) continue;
2515 dir = SvPVx(dirsv,n_a);
2516 if (strcmp(dir,".") == 0) continue;
2517 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2521 p->next = head_PLOC;
2523 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2524 p->dir[NAM$C_MAXRSS] = '\0';
2527 /* most likely spot (ARCHLIB) put first in the list */
2530 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2532 p->next = head_PLOC;
2534 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2535 p->dir[NAM$C_MAXRSS] = '\0';
2544 static int vmspipe_file_status = 0;
2545 static char vmspipe_file[NAM$C_MAXRSS+1];
2547 /* already found? Check and use ... need read+execute permission */
2549 if (vmspipe_file_status == 1) {
2550 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2551 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2552 return vmspipe_file;
2554 vmspipe_file_status = 0;
2557 /* scan through stored @INC, $^X */
2559 if (vmspipe_file_status == 0) {
2560 char file[NAM$C_MAXRSS+1];
2561 pPLOC p = head_PLOC;
2564 strcpy(file, p->dir);
2565 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2566 file[NAM$C_MAXRSS] = '\0';
2569 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2571 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2572 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2573 vmspipe_file_status = 1;
2574 return vmspipe_file;
2577 vmspipe_file_status = -1; /* failed, use tempfiles */
2584 vmspipe_tempfile(pTHX)
2586 char file[NAM$C_MAXRSS+1];
2588 static int index = 0;
2591 /* create a tempfile */
2593 /* we can't go from W, shr=get to R, shr=get without
2594 an intermediate vulnerable state, so don't bother trying...
2596 and lib$spawn doesn't shr=put, so have to close the write
2598 So... match up the creation date/time and the FID to
2599 make sure we're dealing with the same file
2604 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2605 fp = fopen(file,"w");
2607 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2608 fp = fopen(file,"w");
2610 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2611 fp = fopen(file,"w");
2614 if (!fp) return 0; /* we're hosed */
2616 fprintf(fp,"$! 'f$verify(0)'\n");
2617 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
2618 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
2619 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2620 fprintf(fp,"$ perl_on = \"set noon\"\n");
2621 fprintf(fp,"$ perl_exit = \"exit\"\n");
2622 fprintf(fp,"$ perl_del = \"delete\"\n");
2623 fprintf(fp,"$ pif = \"if\"\n");
2624 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2625 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
2626 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
2627 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
2628 fprintf(fp,"$! --- build command line to get max possible length\n");
2629 fprintf(fp,"$c=perl_popen_cmd0\n");
2630 fprintf(fp,"$c=c+perl_popen_cmd1\n");
2631 fprintf(fp,"$c=c+perl_popen_cmd2\n");
2632 fprintf(fp,"$x=perl_popen_cmd3\n");
2633 fprintf(fp,"$c=c+x\n");
2634 fprintf(fp,"$ perl_on\n");
2635 fprintf(fp,"$ 'c'\n");
2636 fprintf(fp,"$ perl_status = $STATUS\n");
2637 fprintf(fp,"$ perl_del 'perl_cfile'\n");
2638 fprintf(fp,"$ perl_exit 'perl_status'\n");
2641 fgetname(fp, file, 1);
2642 fstat(fileno(fp), &s0);
2645 fp = fopen(file,"r","shr=get");
2647 fstat(fileno(fp), &s1);
2649 if (s0.st_ino[0] != s1.st_ino[0] ||
2650 s0.st_ino[1] != s1.st_ino[1] ||
2651 s0.st_ino[2] != s1.st_ino[2] ||
2652 s0.st_ctime != s1.st_ctime ) {
2663 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
2665 static int handler_set_up = FALSE;
2666 unsigned long int sts, flags = CLI$M_NOWAIT;
2667 /* The use of a GLOBAL table (as was done previously) rendered
2668 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
2669 * environment. Hence we've switched to LOCAL symbol table.
2671 unsigned int table = LIB$K_CLI_LOCAL_SYM;
2673 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2674 char in[512], out[512], err[512], mbx[512];
2676 char tfilebuf[NAM$C_MAXRSS+1];
2678 char cmd_sym_name[20];
2679 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2680 DSC$K_CLASS_S, symbol};
2681 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2683 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2684 DSC$K_CLASS_S, cmd_sym_name};
2685 struct dsc$descriptor_s *vmscmd;
2686 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2687 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2688 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2690 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
2692 /* once-per-program initialization...
2693 note that the SETAST calls and the dual test of pipe_ef
2694 makes sure that only the FIRST thread through here does
2695 the initialization...all other threads wait until it's
2698 Yeah, uglier than a pthread call, it's got all the stuff inline
2699 rather than in a separate routine.
2703 _ckvmssts(sys$setast(0));
2705 unsigned long int pidcode = JPI$_PID;
2706 $DESCRIPTOR(d_delay, RETRY_DELAY);
2707 _ckvmssts(lib$get_ef(&pipe_ef));
2708 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2709 _ckvmssts(sys$bintim(&d_delay, delaytime));
2711 if (!handler_set_up) {
2712 _ckvmssts(sys$dclexh(&pipe_exitblock));
2713 handler_set_up = TRUE;
2715 _ckvmssts(sys$setast(1));
2718 /* see if we can find a VMSPIPE.COM */
2721 vmspipe = find_vmspipe(aTHX);
2723 strcpy(tfilebuf+1,vmspipe);
2724 } else { /* uh, oh...we're in tempfile hell */
2725 tpipe = vmspipe_tempfile(aTHX);
2726 if (!tpipe) { /* a fish popular in Boston */
2727 if (ckWARN(WARN_PIPE)) {
2728 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
2732 fgetname(tpipe,tfilebuf+1,1);
2734 vmspipedsc.dsc$a_pointer = tfilebuf;
2735 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2737 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
2740 case RMS$_FNF: case RMS$_DNF:
2741 set_errno(ENOENT); break;
2743 set_errno(ENOTDIR); break;
2745 set_errno(ENODEV); break;
2747 set_errno(EACCES); break;
2749 set_errno(EINVAL); break;
2750 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2751 set_errno(E2BIG); break;
2752 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2753 _ckvmssts(sts); /* fall through */
2754 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2757 set_vaxc_errno(sts);
2758 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2759 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2766 strcpy(mode,in_mode);
2769 info->completion = 0;
2770 info->closing = FALSE;
2777 info->in_done = TRUE;
2778 info->out_done = TRUE;
2779 info->err_done = TRUE;
2780 in[0] = out[0] = err[0] = '\0';
2782 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
2786 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
2791 if (*mode == 'r') { /* piping from subroutine */
2793 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2795 info->out->pipe_done = &info->out_done;
2796 info->out_done = FALSE;
2797 info->out->info = info;
2799 if (!info->useFILE) {
2800 info->fp = PerlIO_open(mbx, mode);
2802 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2803 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2806 if (!info->fp && info->out) {
2807 sys$cancel(info->out->chan_out);
2809 while (!info->out_done) {
2811 _ckvmssts(sys$setast(0));
2812 done = info->out_done;
2813 if (!done) _ckvmssts(sys$clref(pipe_ef));
2814 _ckvmssts(sys$setast(1));
2815 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2818 if (info->out->buf) Safefree(info->out->buf);
2819 Safefree(info->out);
2825 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2827 info->err->pipe_done = &info->err_done;
2828 info->err_done = FALSE;
2829 info->err->info = info;
2832 } else if (*mode == 'w') { /* piping to subroutine */
2834 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2836 info->out->pipe_done = &info->out_done;
2837 info->out_done = FALSE;
2838 info->out->info = info;
2841 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2843 info->err->pipe_done = &info->err_done;
2844 info->err_done = FALSE;
2845 info->err->info = info;
2848 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2849 if (!info->useFILE) {
2850 info->fp = PerlIO_open(mbx, mode);
2852 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2853 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2857 info->in->pipe_done = &info->in_done;
2858 info->in_done = FALSE;
2859 info->in->info = info;
2863 if (!info->fp && info->in) {
2865 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2866 0, 0, 0, 0, 0, 0, 0, 0));
2868 while (!info->in_done) {
2870 _ckvmssts(sys$setast(0));
2871 done = info->in_done;
2872 if (!done) _ckvmssts(sys$clref(pipe_ef));
2873 _ckvmssts(sys$setast(1));
2874 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2877 if (info->in->buf) Safefree(info->in->buf);
2885 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
2886 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2888 info->out->pipe_done = &info->out_done;
2889 info->out_done = FALSE;
2890 info->out->info = info;
2893 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2895 info->err->pipe_done = &info->err_done;
2896 info->err_done = FALSE;
2897 info->err->info = info;
2901 symbol[MAX_DCL_SYMBOL] = '\0';
2903 strncpy(symbol, in, MAX_DCL_SYMBOL);
2904 d_symbol.dsc$w_length = strlen(symbol);
2905 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2907 strncpy(symbol, err, MAX_DCL_SYMBOL);
2908 d_symbol.dsc$w_length = strlen(symbol);
2909 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2911 strncpy(symbol, out, MAX_DCL_SYMBOL);
2912 d_symbol.dsc$w_length = strlen(symbol);
2913 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2915 p = vmscmd->dsc$a_pointer;
2916 while (*p && *p != '\n') p++;
2917 *p = '\0'; /* truncate on \n */
2918 p = vmscmd->dsc$a_pointer;
2919 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2920 if (*p == '$') p++; /* remove leading $ */
2921 while (*p == ' ' || *p == '\t') p++;
2923 for (j = 0; j < 4; j++) {
2924 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2925 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2927 strncpy(symbol, p, MAX_DCL_SYMBOL);
2928 d_symbol.dsc$w_length = strlen(symbol);
2929 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2931 if (strlen(p) > MAX_DCL_SYMBOL) {
2932 p += MAX_DCL_SYMBOL;
2937 _ckvmssts(sys$setast(0));
2938 info->next=open_pipes; /* prepend to list */
2940 _ckvmssts(sys$setast(1));
2941 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
2942 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
2943 * have SYS$COMMAND if we need it.
2945 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
2946 0, &info->pid, &info->completion,
2947 0, popen_completion_ast,info,0,0,0));
2949 /* if we were using a tempfile, close it now */
2951 if (tpipe) fclose(tpipe);
2953 /* once the subprocess is spawned, it has copied the symbols and
2954 we can get rid of ours */
2956 for (j = 0; j < 4; j++) {
2957 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2958 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2959 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2961 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2962 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2963 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2964 vms_execfree(vmscmd);
2966 #ifdef PERL_IMPLICIT_CONTEXT
2969 PL_forkprocess = info->pid;
2974 _ckvmssts(sys$setast(0));
2976 if (!done) _ckvmssts(sys$clref(pipe_ef));
2977 _ckvmssts(sys$setast(1));
2978 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2980 *psts = info->completion;
2981 /* Caller thinks it is open and tries to close it. */
2982 /* This causes some problems, as it changes the error status */
2983 /* my_pclose(info->fp); */
2988 } /* end of safe_popen */
2991 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2993 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2997 TAINT_PROPER("popen");
2998 PERL_FLUSHALL_FOR_CHILD;
2999 return safe_popen(aTHX_ cmd,mode,&sts);
3004 /*{{{ I32 my_pclose(PerlIO *fp)*/
3005 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3007 pInfo info, last = NULL;
3008 unsigned long int retsts;
3011 for (info = open_pipes; info != NULL; last = info, info = info->next)
3012 if (info->fp == fp) break;
3014 if (info == NULL) { /* no such pipe open */
3015 set_errno(ECHILD); /* quoth POSIX */
3016 set_vaxc_errno(SS$_NONEXPR);
3020 /* If we were writing to a subprocess, insure that someone reading from
3021 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
3022 * produce an EOF record in the mailbox.
3024 * well, at least sometimes it *does*, so we have to watch out for
3025 * the first EOF closing the pipe (and DASSGN'ing the channel)...
3029 PerlIO_flush(info->fp); /* first, flush data */
3031 fflush((FILE *)info->fp);
3034 _ckvmssts(sys$setast(0));
3035 info->closing = TRUE;
3036 done = info->done && info->in_done && info->out_done && info->err_done;
3037 /* hanging on write to Perl's input? cancel it */
3038 if (info->mode == 'r' && info->out && !info->out_done) {
3039 if (info->out->chan_out) {
3040 _ckvmssts(sys$cancel(info->out->chan_out));
3041 if (!info->out->chan_in) { /* EOF generation, need AST */
3042 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3046 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
3047 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3049 _ckvmssts(sys$setast(1));
3052 PerlIO_close(info->fp);
3054 fclose((FILE *)info->fp);
3057 we have to wait until subprocess completes, but ALSO wait until all
3058 the i/o completes...otherwise we'll be freeing the "info" structure
3059 that the i/o ASTs could still be using...
3063 _ckvmssts(sys$setast(0));
3064 done = info->done && info->in_done && info->out_done && info->err_done;
3065 if (!done) _ckvmssts(sys$clref(pipe_ef));
3066 _ckvmssts(sys$setast(1));
3067 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3069 retsts = info->completion;
3071 /* remove from list of open pipes */
3072 _ckvmssts(sys$setast(0));
3073 if (last) last->next = info->next;
3074 else open_pipes = info->next;
3075 _ckvmssts(sys$setast(1));
3077 /* free buffers and structures */
3080 if (info->in->buf) Safefree(info->in->buf);
3084 if (info->out->buf) Safefree(info->out->buf);
3085 Safefree(info->out);
3088 if (info->err->buf) Safefree(info->err->buf);
3089 Safefree(info->err);
3095 } /* end of my_pclose() */
3097 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3098 /* Roll our own prototype because we want this regardless of whether
3099 * _VMS_WAIT is defined.
3101 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3103 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3104 created with popen(); otherwise partially emulate waitpid() unless
3105 we have a suitable one from the CRTL that came with VMS 7.2 and later.
3106 Also check processes not considered by the CRTL waitpid().
3108 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3110 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3117 if (statusp) *statusp = 0;
3119 for (info = open_pipes; info != NULL; info = info->next)
3120 if (info->pid == pid) break;
3122 if (info != NULL) { /* we know about this child */
3123 while (!info->done) {
3124 _ckvmssts(sys$setast(0));
3126 if (!done) _ckvmssts(sys$clref(pipe_ef));
3127 _ckvmssts(sys$setast(1));
3128 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3131 if (statusp) *statusp = info->completion;
3135 /* child that already terminated? */
3137 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3138 if (closed_list[j].pid == pid) {
3139 if (statusp) *statusp = closed_list[j].completion;
3144 /* fall through if this child is not one of our own pipe children */
3146 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3148 /* waitpid() became available in the CRTL as of VMS 7.0, but only
3149 * in 7.2 did we get a version that fills in the VMS completion
3150 * status as Perl has always tried to do.
3153 sts = __vms_waitpid( pid, statusp, flags );
3155 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3158 /* If the real waitpid tells us the child does not exist, we
3159 * fall through here to implement waiting for a child that
3160 * was created by some means other than exec() (say, spawned
3161 * from DCL) or to wait for a process that is not a subprocess
3162 * of the current process.
3165 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3168 $DESCRIPTOR(intdsc,"0 00:00:01");
3169 unsigned long int ownercode = JPI$_OWNER, ownerpid;
3170 unsigned long int pidcode = JPI$_PID, mypid;
3171 unsigned long int interval[2];
3172 unsigned int jpi_iosb[2];
3173 struct itmlst_3 jpilist[2] = {
3174 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
3179 /* Sorry folks, we don't presently implement rooting around for
3180 the first child we can find, and we definitely don't want to
3181 pass a pid of -1 to $getjpi, where it is a wildcard operation.
3187 /* Get the owner of the child so I can warn if it's not mine. If the
3188 * process doesn't exist or I don't have the privs to look at it,
3189 * I can go home early.
3191 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3192 if (sts & 1) sts = jpi_iosb[0];
3204 set_vaxc_errno(sts);
3208 if (ckWARN(WARN_EXEC)) {
3209 /* remind folks they are asking for non-standard waitpid behavior */
3210 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3211 if (ownerpid != mypid)
3212 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3213 "waitpid: process %x is not a child of process %x",
3217 /* simply check on it once a second until it's not there anymore. */
3219 _ckvmssts(sys$bintim(&intdsc,interval));
3220 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3221 _ckvmssts(sys$schdwk(0,0,interval,0));
3222 _ckvmssts(sys$hiber());
3224 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3229 } /* end of waitpid() */
3234 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3236 my_gconvert(double val, int ndig, int trail, char *buf)
3238 static char __gcvtbuf[DBL_DIG+1];
3241 loc = buf ? buf : __gcvtbuf;
3243 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
3245 sprintf(loc,"%.*g",ndig,val);
3251 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3252 return gcvt(val,ndig,loc);
3255 loc[0] = '0'; loc[1] = '\0';
3263 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3264 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
3265 * to expand file specification. Allows for a single default file
3266 * specification and a simple mask of options. If outbuf is non-NULL,
3267 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3268 * the resultant file specification is placed. If outbuf is NULL, the
3269 * resultant file specification is placed into a static buffer.
3270 * The third argument, if non-NULL, is taken to be a default file
3271 * specification string. The fourth argument is unused at present.
3272 * rmesexpand() returns the address of the resultant string if
3273 * successful, and NULL on error.
3275 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
3278 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3280 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
3281 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
3282 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3283 struct FAB myfab = cc$rms_fab;
3284 struct NAM mynam = cc$rms_nam;
3286 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3289 if (!filespec || !*filespec) {
3290 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3294 if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
3295 else outbuf = __rmsexpand_retbuf;
3297 if ((isunix = (strchr(filespec,'/') != NULL))) {
3298 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
3299 filespec = vmsfspec;
3302 myfab.fab$l_fna = (char *)filespec; /* cast ok for read only pointer */
3303 myfab.fab$b_fns = strlen(filespec);
3304 myfab.fab$l_nam = &mynam;
3306 if (defspec && *defspec) {
3307 if (strchr(defspec,'/') != NULL) {
3308 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
3311 myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
3312 myfab.fab$b_dns = strlen(defspec);
3315 mynam.nam$l_esa = esa;
3316 mynam.nam$b_ess = sizeof esa;
3317 mynam.nam$l_rsa = outbuf;
3318 mynam.nam$b_rss = NAM$C_MAXRSS;
3320 retsts = sys$parse(&myfab,0,0);
3321 if (!(retsts & 1)) {
3322 mynam.nam$b_nop |= NAM$M_SYNCHK;
3323 #ifdef NAM$M_NO_SHORT_UPCASE
3324 if (decc_efs_case_preserve)
3325 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3327 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
3328 retsts = sys$parse(&myfab,0,0);
3329 if (retsts & 1) goto expanded;
3331 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3332 sts = sys$parse(&myfab,0,0); /* Free search context */
3333 if (out) Safefree(out);
3334 set_vaxc_errno(retsts);
3335 if (retsts == RMS$_PRV) set_errno(EACCES);
3336 else if (retsts == RMS$_DEV) set_errno(ENODEV);
3337 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3338 else set_errno(EVMSERR);
3341 retsts = sys$search(&myfab,0,0);
3342 if (!(retsts & 1) && retsts != RMS$_FNF) {
3343 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3344 #ifdef NAM$M_NO_SHORT_UPCASE
3345 if (decc_efs_case_preserve)
3346 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3348 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
3349 if (out) Safefree(out);
3350 set_vaxc_errno(retsts);
3351 if (retsts == RMS$_PRV) set_errno(EACCES);
3352 else set_errno(EVMSERR);
3356 /* If the input filespec contained any lowercase characters,
3357 * downcase the result for compatibility with Unix-minded code. */
3359 if (!decc_efs_case_preserve) {
3360 for (out = myfab.fab$l_fna; *out; out++)
3361 if (islower(*out)) { haslower = 1; break; }
3363 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3364 else { out = esa; speclen = mynam.nam$b_esl; }
3365 /* Trim off null fields added by $PARSE
3366 * If type > 1 char, must have been specified in original or default spec
3367 * (not true for version; $SEARCH may have added version of existing file).
3369 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3370 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3371 (mynam.nam$l_ver - mynam.nam$l_type == 1);
3372 if (trimver || trimtype) {
3373 if (defspec && *defspec) {
3374 char defesa[NAM$C_MAXRSS];
3375 struct FAB deffab = cc$rms_fab;
3376 struct NAM defnam = cc$rms_nam;
3378 deffab.fab$l_nam = &defnam;
3379 /* cast below ok for read only pointer */
3380 deffab.fab$l_fna = (char *)defspec; deffab.fab$b_fns = myfab.fab$b_dns;
3381 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
3382 defnam.nam$b_nop = NAM$M_SYNCHK;
3383 #ifdef NAM$M_NO_SHORT_UPCASE
3384 if (decc_efs_case_preserve)
3385 defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3387 if (sys$parse(&deffab,0,0) & 1) {
3388 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
3389 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
3392 if (trimver) speclen = mynam.nam$l_ver - out;
3394 /* If we didn't already trim version, copy down */
3395 if (speclen > mynam.nam$l_ver - out)
3396 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
3397 speclen - (mynam.nam$l_ver - out));
3398 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
3401 /* If we just had a directory spec on input, $PARSE "helpfully"
3402 * adds an empty name and type for us */
3403 if (mynam.nam$l_name == mynam.nam$l_type &&
3404 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
3405 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
3406 speclen = mynam.nam$l_name - out;
3407 out[speclen] = '\0';
3408 if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
3410 /* Have we been working with an expanded, but not resultant, spec? */
3411 /* Also, convert back to Unix syntax if necessary. */
3412 if (!mynam.nam$b_rsl) {
3414 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
3416 else strcpy(outbuf,esa);
3419 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
3420 strcpy(outbuf,tmpfspec);
3422 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3423 #ifdef NAM$M_NO_SHORT_UPCASE
3424 if (decc_efs_case_preserve)
3425 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3427 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
3428 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
3432 /* External entry points */
3433 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
3434 { return do_rmsexpand(spec,buf,0,def,opt); }
3435 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
3436 { return do_rmsexpand(spec,buf,1,def,opt); }
3440 ** The following routines are provided to make life easier when
3441 ** converting among VMS-style and Unix-style directory specifications.
3442 ** All will take input specifications in either VMS or Unix syntax. On
3443 ** failure, all return NULL. If successful, the routines listed below
3444 ** return a pointer to a buffer containing the appropriately
3445 ** reformatted spec (and, therefore, subsequent calls to that routine
3446 ** will clobber the result), while the routines of the same names with
3447 ** a _ts suffix appended will return a pointer to a mallocd string
3448 ** containing the appropriately reformatted spec.
3449 ** In all cases, only explicit syntax is altered; no check is made that
3450 ** the resulting string is valid or that the directory in question
3453 ** fileify_dirspec() - convert a directory spec into the name of the
3454 ** directory file (i.e. what you can stat() to see if it's a dir).
3455 ** The style (VMS or Unix) of the result is the same as the style
3456 ** of the parameter passed in.
3457 ** pathify_dirspec() - convert a directory spec into a path (i.e.
3458 ** what you prepend to a filename to indicate what directory it's in).
3459 ** The style (VMS or Unix) of the result is the same as the style
3460 ** of the parameter passed in.
3461 ** tounixpath() - convert a directory spec into a Unix-style path.
3462 ** tovmspath() - convert a directory spec into a VMS-style path.
3463 ** tounixspec() - convert any file spec into a Unix-style file spec.
3464 ** tovmsspec() - convert any file spec into a VMS-style spec.
3466 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
3467 ** Permission is given to distribute this code as part of the Perl
3468 ** standard distribution under the terms of the GNU General Public
3469 ** License or the Perl Artistic License. Copies of each may be
3470 ** found in the Perl standard distribution.
3473 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
3474 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
3476 static char __fileify_retbuf[NAM$C_MAXRSS+1];
3477 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
3478 char *retspec, *cp1, *cp2, *lastdir;
3479 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
3480 unsigned short int trnlnm_iter_count;
3483 if (!dir || !*dir) {
3484 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3486 dirlen = strlen(dir);
3487 while (dirlen && dir[dirlen-1] == '/') --dirlen;
3488 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3489 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
3496 if (dirlen > NAM$C_MAXRSS) {
3497 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3499 if (!strpbrk(dir+1,"/]>:") &&
3500 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
3501 strcpy(trndir,*dir == '/' ? dir + 1: dir);
3502 trnlnm_iter_count = 0;
3503 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
3504 trnlnm_iter_count++;
3505 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3507 dirlen = strlen(trndir);
3510 strncpy(trndir,dir,dirlen);
3511 trndir[dirlen] = '\0';
3514 /* At this point we are done with *dir and use *trndir which is a
3515 * copy that can be modified. *dir must not be modified.
3518 /* If we were handed a rooted logical name or spec, treat it like a
3519 * simple directory, so that
3520 * $ Define myroot dev:[dir.]
3521 * ... do_fileify_dirspec("myroot",buf,1) ...
3522 * does something useful.
3524 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
3525 trndir[--dirlen] = '\0';
3526 trndir[dirlen-1] = ']';
3528 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
3529 trndir[--dirlen] = '\0';
3530 trndir[dirlen-1] = '>';
3533 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
3534 /* If we've got an explicit filename, we can just shuffle the string. */
3535 if (*(cp1+1)) hasfilename = 1;
3536 /* Similarly, we can just back up a level if we've got multiple levels
3537 of explicit directories in a VMS spec which ends with directories. */
3539 for (cp2 = cp1; cp2 > trndir; cp2--) {
3541 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
3542 *cp2 = *cp1; *cp1 = '\0';
3547 if (*cp2 == '[' || *cp2 == '<') break;
3552 cp1 = strpbrk(trndir,"]:>"); /* Prepare for future change */
3553 if (hasfilename || !cp1) { /* Unix-style path or filename */
3554 if (trndir[0] == '.') {
3555 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0'))
3556 return do_fileify_dirspec("[]",buf,ts);
3557 else if (trndir[1] == '.' &&
3558 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0')))
3559 return do_fileify_dirspec("[-]",buf,ts);
3561 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
3562 dirlen -= 1; /* to last element */
3563 lastdir = strrchr(trndir,'/');
3565 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
3566 /* If we have "/." or "/..", VMSify it and let the VMS code
3567 * below expand it, rather than repeating the code to handle
3568 * relative components of a filespec here */
3570 if (*(cp1+2) == '.') cp1++;
3571 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3572 if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
3573 if (strchr(vmsdir,'/') != NULL) {
3574 /* If do_tovmsspec() returned it, it must have VMS syntax
3575 * delimiters in it, so it's a mixed VMS/Unix spec. We take
3576 * the time to check this here only so we avoid a recursion
3577 * loop; otherwise, gigo.
3579 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
3581 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3582 return do_tounixspec(trndir,buf,ts);
3585 } while ((cp1 = strstr(cp1,"/.")) != NULL);
3586 lastdir = strrchr(trndir,'/');
3588 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
3589 /* Ditto for specs that end in an MFD -- let the VMS code
3590 * figure out whether it's a real device or a rooted logical. */
3592 /* This should not happen any more. Allowing the fake /000000
3593 * in a UNIX pathname causes all sorts of problems when trying
3594 * to run in UNIX emulation. So the VMS to UNIX conversions
3595 * now remove the fake /000000 directories.
3598 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
3599 if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
3600 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3601 return do_tounixspec(trndir,buf,ts);
3605 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
3606 !(lastdir = cp1 = strrchr(trndir,']')) &&
3607 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
3608 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
3611 /* For EFS or ODS-5 look for the last dot */
3612 if (decc_efs_charset) {
3613 cp2 = strrchr(cp1,'.');
3615 if (vms_process_case_tolerant) {
3616 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3617 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3618 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3619 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3620 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3621 (ver || *cp3)))))) {
3623 set_vaxc_errno(RMS$_DIR);
3628 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
3629 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
3630 !*(cp2+3) || *(cp2+3) != 'R' ||
3631 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3632 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3633 (ver || *cp3)))))) {
3635 set_vaxc_errno(RMS$_DIR);
3639 dirlen = cp2 - trndir;
3643 retlen = dirlen + 6;
3644 if (buf) retspec = buf;
3645 else if (ts) Newx(retspec,retlen+1,char);
3646 else retspec = __fileify_retbuf;
3647 memcpy(retspec,trndir,dirlen);
3648 retspec[dirlen] = '\0';
3650 /* We've picked up everything up to the directory file name.
3651 Now just add the type and version, and we're set. */
3652 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
3653 strcat(retspec,".dir;1");
3655 strcat(retspec,".DIR;1");
3658 else { /* VMS-style directory spec */
3659 char esa[NAM$C_MAXRSS+1], term, *cp;
3660 unsigned long int sts, cmplen, haslower = 0;
3661 struct FAB dirfab = cc$rms_fab;
3662 struct NAM savnam, dirnam = cc$rms_nam;
3664 dirfab.fab$b_fns = strlen(trndir);
3665 dirfab.fab$l_fna = trndir;
3666 dirfab.fab$l_nam = &dirnam;
3667 dirfab.fab$l_dna = ".DIR;1";
3668 dirfab.fab$b_dns = 6;
3669 dirnam.nam$b_ess = NAM$C_MAXRSS;
3670 dirnam.nam$l_esa = esa;
3671 #ifdef NAM$M_NO_SHORT_UPCASE
3672 if (decc_efs_case_preserve)
3673 dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3676 for (cp = trndir; *cp; cp++)
3677 if (islower(*cp)) { haslower = 1; break; }
3678 if (!((sts = sys$parse(&dirfab))&1)) {
3679 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
3680 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3681 sts = sys$parse(&dirfab) & 1;
3685 set_vaxc_errno(dirfab.fab$l_sts);
3691 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3692 /* Yes; fake the fnb bits so we'll check type below */
3693 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3695 else { /* No; just work with potential name */
3696 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3698 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3699 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3700 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
3705 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3706 cp1 = strchr(esa,']');
3707 if (!cp1) cp1 = strchr(esa,'>');
3708 if (cp1) { /* Should always be true */
3709 dirnam.nam$b_esl -= cp1 - esa - 1;
3710 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3713 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3714 /* Yep; check version while we're at it, if it's there. */
3715 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3716 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3717 /* Something other than .DIR[;1]. Bzzt. */
3718 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3719 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
3721 set_vaxc_errno(RMS$_DIR);
3725 esa[dirnam.nam$b_esl] = '\0';
3726 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3727 /* They provided at least the name; we added the type, if necessary, */
3728 if (buf) retspec = buf; /* in sys$parse() */
3729 else if (ts) Newx(retspec,dirnam.nam$b_esl+1,char);
3730 else retspec = __fileify_retbuf;
3731 strcpy(retspec,esa);
3732 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3733 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
3736 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3737 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3739 dirnam.nam$b_esl -= 9;
3741 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3742 if (cp1 == NULL) { /* should never happen */
3743 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3744 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
3749 retlen = strlen(esa);
3750 cp1 = strrchr(esa,'.');
3751 /* ODS-5 directory specifications can have extra "." in them. */
3752 while (cp1 != NULL) {
3753 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
3757 while ((cp1 > esa) && (*cp1 != '.'))
3764 if ((cp1) != NULL) {
3765 /* There's more than one directory in the path. Just roll back. */
3767 if (buf) retspec = buf;
3768 else if (ts) Newx(retspec,retlen+7,char);
3769 else retspec = __fileify_retbuf;
3770 strcpy(retspec,esa);
3773 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3774 /* Go back and expand rooted logical name */
3775 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3776 #ifdef NAM$M_NO_SHORT_UPCASE
3777 if (decc_efs_case_preserve)
3778 dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3780 if (!(sys$parse(&dirfab) & 1)) {
3781 dirnam.nam$l_rlf = NULL;
3782 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
3784 set_vaxc_errno(dirfab.fab$l_sts);
3787 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3788 if (buf) retspec = buf;
3789 else if (ts) Newx(retspec,retlen+16,char);
3790 else retspec = __fileify_retbuf;
3791 cp1 = strstr(esa,"][");
3792 if (!cp1) cp1 = strstr(esa,"]<");
3794 memcpy(retspec,esa,dirlen);
3795 if (!strncmp(cp1+2,"000000]",7)) {
3796 retspec[dirlen-1] = '\0';
3797 /* Not full ODS-5, just extra dots in directories for now */
3798 cp1 = retspec + dirlen - 1;
3799 while (cp1 > retspec)
3804 if (*(cp1-1) != '^')
3809 if (*cp1 == '.') *cp1 = ']';
3811 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3812 memcpy(cp1+1,"000000]",7);
3816 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3817 retspec[retlen] = '\0';
3818 /* Convert last '.' to ']' */
3819 cp1 = retspec+retlen-1;
3820 while (*cp != '[') {
3823 /* Do not trip on extra dots in ODS-5 directories */
3824 if ((cp1 == retspec) || (*(cp1-1) != '^'))
3828 if (*cp1 == '.') *cp1 = ']';
3830 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3831 memcpy(cp1+1,"000000]",7);
3835 else { /* This is a top-level dir. Add the MFD to the path. */
3836 if (buf) retspec = buf;
3837 else if (ts) Newx(retspec,retlen+16,char);
3838 else retspec = __fileify_retbuf;
3841 while (*cp1 != ':') *(cp2++) = *(cp1++);
3842 strcpy(cp2,":[000000]");
3847 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3848 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
3849 /* We've set up the string up through the filename. Add the
3850 type and version, and we're done. */
3851 strcat(retspec,".DIR;1");
3853 /* $PARSE may have upcased filespec, so convert output to lower
3854 * case if input contained any lowercase characters. */
3855 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
3858 } /* end of do_fileify_dirspec() */
3860 /* External entry points */
3861 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
3862 { return do_fileify_dirspec(dir,buf,0); }
3863 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
3864 { return do_fileify_dirspec(dir,buf,1); }
3866 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3867 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
3869 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3870 unsigned long int retlen;
3871 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3872 unsigned short int trnlnm_iter_count;
3876 if (!dir || !*dir) {
3877 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3880 if (*dir) strcpy(trndir,dir);
3881 else getcwd(trndir,sizeof trndir - 1);
3883 trnlnm_iter_count = 0;
3884 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3885 && my_trnlnm(trndir,trndir,0)) {
3886 trnlnm_iter_count++;
3887 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3888 trnlen = strlen(trndir);
3890 /* Trap simple rooted lnms, and return lnm:[000000] */
3891 if (!strcmp(trndir+trnlen-2,".]")) {
3892 if (buf) retpath = buf;
3893 else if (ts) Newx(retpath,strlen(dir)+10,char);
3894 else retpath = __pathify_retbuf;
3895 strcpy(retpath,dir);
3896 strcat(retpath,":[000000]");
3901 /* At this point we do not work with *dir, but the copy in
3902 * *trndir that is modifiable.
3905 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
3906 if (*trndir == '.' && (*(trndir+1) == '\0' ||
3907 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
3908 retlen = 2 + (*(trndir+1) != '\0');
3910 if ( !(cp1 = strrchr(trndir,'/')) &&
3911 !(cp1 = strrchr(trndir,']')) &&
3912 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
3913 if ((cp2 = strchr(cp1,'.')) != NULL &&
3914 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3915 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3916 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3917 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3920 /* For EFS or ODS-5 look for the last dot */
3921 if (decc_efs_charset) {
3922 cp2 = strrchr(cp1,'.');
3924 if (vms_process_case_tolerant) {
3925 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3926 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3927 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3928 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3929 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3930 (ver || *cp3)))))) {
3932 set_vaxc_errno(RMS$_DIR);
3937 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
3938 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
3939 !*(cp2+3) || *(cp2+3) != 'R' ||
3940 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3941 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3942 (ver || *cp3)))))) {
3944 set_vaxc_errno(RMS$_DIR);
3948 retlen = cp2 - trndir + 1;
3950 else { /* No file type present. Treat the filename as a directory. */
3951 retlen = strlen(trndir) + 1;
3954 if (buf) retpath = buf;
3955 else if (ts) Newx(retpath,retlen+1,char);
3956 else retpath = __pathify_retbuf;
3957 strncpy(retpath, trndir, retlen-1);
3958 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3959 retpath[retlen-1] = '/'; /* with '/', add it. */
3960 retpath[retlen] = '\0';
3962 else retpath[retlen-1] = '\0';
3964 else { /* VMS-style directory spec */
3965 char esa[NAM$C_MAXRSS+1], *cp;
3966 unsigned long int sts, cmplen, haslower;
3967 struct FAB dirfab = cc$rms_fab;
3968 struct NAM savnam, dirnam = cc$rms_nam;
3970 /* If we've got an explicit filename, we can just shuffle the string. */
3971 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
3972 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
3973 if ((cp2 = strchr(cp1,'.')) != NULL) {
3975 if (vms_process_case_tolerant) {
3976 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3977 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3978 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3979 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3980 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3981 (ver || *cp3)))))) {
3983 set_vaxc_errno(RMS$_DIR);
3988 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
3989 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
3990 !*(cp2+3) || *(cp2+3) != 'R' ||
3991 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3992 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3993 (ver || *cp3)))))) {
3995 set_vaxc_errno(RMS$_DIR);
4000 else { /* No file type, so just draw name into directory part */
4001 for (cp2 = cp1; *cp2; cp2++) ;
4004 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
4006 /* We've now got a VMS 'path'; fall through */
4008 dirfab.fab$b_fns = strlen(trndir);
4009 dirfab.fab$l_fna = trndir;
4010 if (trndir[dirfab.fab$b_fns-1] == ']' ||
4011 trndir[dirfab.fab$b_fns-1] == '>' ||
4012 trndir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
4013 if (buf) retpath = buf;
4014 else if (ts) Newx(retpath,strlen(trndir)+1,char);
4015 else retpath = __pathify_retbuf;
4016 strcpy(retpath,trndir);
4019 dirfab.fab$l_dna = ".DIR;1";
4020 dirfab.fab$b_dns = 6;
4021 dirfab.fab$l_nam = &dirnam;
4022 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
4023 dirnam.nam$l_esa = esa;
4024 #ifdef NAM$M_NO_SHORT_UPCASE
4025 if (decc_efs_case_preserve)
4026 dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4029 for (cp = trndir; *cp; cp++)
4030 if (islower(*cp)) { haslower = 1; break; }
4032 if (!(sts = (sys$parse(&dirfab)&1))) {
4033 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4034 dirnam.nam$b_nop |= NAM$M_SYNCHK;
4035 sts = sys$parse(&dirfab) & 1;
4039 set_vaxc_errno(dirfab.fab$l_sts);
4045 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
4046 if (dirfab.fab$l_sts != RMS$_FNF) {
4048 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
4049 dirfab.fab$b_dns = 0;
4050 sts1 = sys$parse(&dirfab,0,0);
4052 set_vaxc_errno(dirfab.fab$l_sts);
4055 dirnam = savnam; /* No; just work with potential name */
4058 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
4059 /* Yep; check version while we're at it, if it's there. */
4060 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
4061 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
4063 /* Something other than .DIR[;1]. Bzzt. */
4064 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
4065 dirfab.fab$b_dns = 0;
4066 sts2 = sys$parse(&dirfab,0,0);
4068 set_vaxc_errno(RMS$_DIR);
4072 /* OK, the type was fine. Now pull any file name into the
4074 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
4076 cp1 = strrchr(esa,'>');
4077 *dirnam.nam$l_type = '>';
4080 *(dirnam.nam$l_type + 1) = '\0';
4081 retlen = dirnam.nam$l_type - esa + 2;
4082 if (buf) retpath = buf;
4083 else if (ts) Newx(retpath,retlen,char);
4084 else retpath = __pathify_retbuf;
4085 strcpy(retpath,esa);
4086 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
4087 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
4088 /* $PARSE may have upcased filespec, so convert output to lower
4089 * case if input contained any lowercase characters. */
4090 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
4094 } /* end of do_pathify_dirspec() */
4096 /* External entry points */
4097 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
4098 { return do_pathify_dirspec(dir,buf,0); }
4099 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
4100 { return do_pathify_dirspec(dir,buf,1); }
4102 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
4103 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
4105 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
4106 char *dirend, *rslt, *cp1, *cp3, tmp[NAM$C_MAXRSS+1];
4108 int devlen, dirlen, retlen = NAM$C_MAXRSS+1;
4109 int expand = 1; /* guarantee room for leading and trailing slashes */
4110 unsigned short int trnlnm_iter_count;
4113 if (spec == NULL) return NULL;
4114 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
4115 if (buf) rslt = buf;
4117 retlen = strlen(spec);
4118 cp1 = strchr(spec,'[');
4119 if (!cp1) cp1 = strchr(spec,'<');
4121 for (cp1++; *cp1; cp1++) {
4122 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
4123 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
4124 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
4127 Newx(rslt,retlen+2+2*expand,char);
4129 else rslt = __tounixspec_retbuf;
4131 cmp_rslt = 0; /* Presume VMS */
4132 cp1 = strchr(spec, '/');
4136 /* Look for EFS ^/ */
4137 if (decc_efs_charset) {
4138 while (cp1 != NULL) {
4141 /* Found illegal VMS, assume UNIX */
4146 cp1 = strchr(cp1, '/');
4150 /* Look for "." and ".." */
4151 if (decc_filename_unix_report) {
4152 if (spec[0] == '.') {
4153 if ((spec[1] == '\0') || (spec[1] == '\n')) {
4157 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
4163 /* This is already UNIX or at least nothing VMS understands */
4171 dirend = strrchr(spec,']');
4172 if (dirend == NULL) dirend = strrchr(spec,'>');
4173 if (dirend == NULL) dirend = strchr(spec,':');
4174 if (dirend == NULL) {
4179 /* Special case 1 - sys$posix_root = / */
4180 #if __CRTL_VER >= 70000000
4181 if (!decc_disable_posix_root) {
4182 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
4190 /* Special case 2 - Convert NLA0: to /dev/null */
4191 #if __CRTL_VER < 70000000
4192 cmp_rslt = strncmp(spec,"NLA0:", 5);
4194 cmp_rslt = strncmp(spec,"nla0:", 5);
4196 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
4198 if (cmp_rslt == 0) {
4199 strcpy(rslt, "/dev/null");
4202 if (spec[6] != '\0') {
4209 /* Also handle special case "SYS$SCRATCH:" */
4210 #if __CRTL_VER < 70000000
4211 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
4213 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
4215 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
4217 if (cmp_rslt == 0) {
4220 islnm = my_trnlnm(tmp, "TMP", 0);
4222 strcpy(rslt, "/tmp");
4225 if (spec[12] != '\0') {
4233 if (*cp2 != '[' && *cp2 != '<') {
4236 else { /* the VMS spec begins with directories */
4238 if (*cp2 == ']' || *cp2 == '>') {
4239 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
4242 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
4243 if (getcwd(tmp,sizeof tmp,1) == NULL) {
4244 if (ts) Safefree(rslt);
4247 trnlnm_iter_count = 0;
4250 while (*cp3 != ':' && *cp3) cp3++;
4252 if (strchr(cp3,']') != NULL) break;
4253 trnlnm_iter_count++;
4254 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
4255 } while (vmstrnenv(tmp,tmp,0,fildev,0));
4257 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
4258 retlen = devlen + dirlen;
4259 Renew(rslt,retlen+1+2*expand,char);
4265 *(cp1++) = *(cp3++);
4266 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
4270 if ((*cp2 == '^')) {
4271 /* EFS file escape, pass the next character as is */
4272 /* Fix me: HEX encoding for UNICODE not implemented */
4275 else if ( *cp2 == '.') {
4276 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
4277 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
4283 for (; cp2 <= dirend; cp2++) {
4284 if ((*cp2 == '^')) {
4285 /* EFS file escape, pass the next character as is */
4286 /* Fix me: HEX encoding for UNICODE not implemented */
4292 if (*(cp2+1) == '[') cp2++;
4294 else if (*cp2 == ']' || *cp2 == '>') {
4295 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
4297 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
4299 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
4300 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
4301 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
4302 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
4303 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
4305 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
4306 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
4310 else if (*cp2 == '-') {
4311 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
4312 while (*cp2 == '-') {
4314 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
4316 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
4317 if (ts) Safefree(rslt); /* filespecs like */
4318 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
4322 else *(cp1++) = *cp2;
4324 else *(cp1++) = *cp2;
4326 while (*cp2) *(cp1++) = *(cp2++);
4329 /* This still leaves /000000/ when working with a
4330 * VMS device root or concealed root.
4336 ulen = strlen(rslt);
4338 /* Get rid of "000000/ in rooted filespecs */
4340 zeros = strstr(rslt, "/000000/");
4341 if (zeros != NULL) {
4343 mlen = ulen - (zeros - rslt) - 7;
4344 memmove(zeros, &zeros[7], mlen);
4353 } /* end of do_tounixspec() */
4355 /* External entry points */
4356 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
4357 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
4359 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
4360 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
4361 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
4362 char *rslt, *dirend;
4367 unsigned long int infront = 0, hasdir = 1;
4371 if (path == NULL) return NULL;
4372 if (buf) rslt = buf;
4373 else if (ts) Newx(rslt,strlen(path)+9,char);
4374 else rslt = __tovmsspec_retbuf;
4375 if (strpbrk(path,"]:>") ||
4376 (dirend = strrchr(path,'/')) == NULL) {
4377 if (path[0] == '.') {
4378 if (path[1] == '\0') strcpy(rslt,"[]");
4379 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
4380 else strcpy(rslt,path); /* probably garbage */
4382 else strcpy(rslt,path);
4386 vms_delim = strpbrk(path,"]:>");
4389 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
4390 if (!*(dirend+2)) dirend +=2;
4391 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
4392 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
4397 lastdot = strrchr(cp2,'.');
4399 char trndev[NAM$C_MAXRSS+1];
4403 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
4405 if (!buf & ts) Renew(rslt,18,char);
4406 if (decc_disable_posix_root) {
4407 strcpy(rslt,"sys$disk:[000000]");
4410 strcpy(rslt,"sys$posix_root:[000000]");
4414 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
4416 islnm = my_trnlnm(rslt,trndev,0);
4418 /* DECC special handling */
4420 if (strcmp(rslt,"bin") == 0) {
4421 strcpy(rslt,"sys$system");
4424 islnm = my_trnlnm(rslt,trndev,0);
4426 else if (strcmp(rslt,"tmp") == 0) {
4427 strcpy(rslt,"sys$scratch");
4430 islnm = my_trnlnm(rslt,trndev,0);
4432 else if (!decc_disable_posix_root) {
4433 strcpy(rslt, "sys$posix_root");
4437 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
4438 islnm = my_trnlnm(rslt,trndev,0);
4440 else if (strcmp(rslt,"dev") == 0) {
4441 if (strncmp(cp2,"/null", 5) == 0) {
4442 if ((cp2[5] == 0) || (cp2[5] == '/')) {
4443 strcpy(rslt,"NLA0");
4447 islnm = my_trnlnm(rslt,trndev,0);
4453 trnend = islnm ? strlen(trndev) - 1 : 0;
4454 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
4455 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
4456 /* If the first element of the path is a logical name, determine
4457 * whether it has to be translated so we can add more directories. */
4458 if (!islnm || rooted) {
4461 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
4465 if (cp2 != dirend) {
4466 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
4467 strcpy(rslt,trndev);
4468 cp1 = rslt + trnend;
4475 if (decc_disable_posix_root) {
4485 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
4486 cp2 += 2; /* skip over "./" - it's redundant */
4487 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
4489 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
4490 *(cp1++) = '-'; /* "../" --> "-" */
4493 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
4494 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
4495 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
4496 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
4499 else if ((cp2 != lastdot) || (lastdot < dirend)) {
4500 /* Escape the extra dots in EFS file specifications */
4503 if (cp2 > dirend) cp2 = dirend;
4505 else *(cp1++) = '.';
4507 for (; cp2 < dirend; cp2++) {
4509 if (*(cp2-1) == '/') continue;
4510 if (*(cp1-1) != '.') *(cp1++) = '.';
4513 else if (!infront && *cp2 == '.') {
4514 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
4515 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
4516 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
4517 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
4518 else if (*(cp1-2) == '[') *(cp1-1) = '-';
4519 else { /* back up over previous directory name */
4521 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
4522 if (*(cp1-1) == '[') {
4523 memcpy(cp1,"000000.",7);
4528 if (cp2 == dirend) break;
4530 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
4531 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
4532 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
4533 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
4535 *(cp1++) = '.'; /* Simulate trailing '/' */
4536 cp2 += 2; /* for loop will incr this to == dirend */
4538 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
4541 if (decc_efs_charset == 0)
4542 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
4544 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
4550 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
4552 if (decc_efs_charset == 0)
4559 else *(cp1++) = *cp2;
4563 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
4564 if (hasdir) *(cp1++) = ']';
4565 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
4566 /* fixme for ODS5 */
4581 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
4582 decc_readdir_dropdotnotype) {
4587 /* trailing dot ==> '^..' on VMS */
4594 *(cp1++) = *(cp2++);
4622 *(cp1++) = *(cp2++);
4625 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
4626 * which is wrong. UNIX notation should be ".dir. unless
4627 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
4628 * changing this behavior could break more things at this time.
4630 if (decc_filename_unix_report != 0) {
4633 *(cp1++) = *(cp2++);
4636 *(cp1++) = *(cp2++);
4639 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
4643 /* Fix me for "^]", but that requires making sure that you do
4644 * not back up past the start of the filename
4646 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
4653 } /* end of do_tovmsspec() */
4655 /* External entry points */
4656 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
4657 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
4659 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
4660 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
4661 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
4663 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
4665 if (path == NULL) return NULL;
4666 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
4667 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
4668 if (buf) return buf;
4670 vmslen = strlen(vmsified);
4671 Newx(cp,vmslen+1,char);
4672 memcpy(cp,vmsified,vmslen);
4677 strcpy(__tovmspath_retbuf,vmsified);
4678 return __tovmspath_retbuf;
4681 } /* end of do_tovmspath() */
4683 /* External entry points */
4684 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
4685 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
4688 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
4689 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
4690 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
4692 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
4694 if (path == NULL) return NULL;
4695 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
4696 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
4697 if (buf) return buf;
4699 unixlen = strlen(unixified);
4700 Newx(cp,unixlen+1,char);
4701 memcpy(cp,unixified,unixlen);
4706 strcpy(__tounixpath_retbuf,unixified);
4707 return __tounixpath_retbuf;
4710 } /* end of do_tounixpath() */
4712 /* External entry points */
4713 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
4714 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
4717 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
4719 *****************************************************************************
4721 * Copyright (C) 1989-1994 by *
4722 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
4724 * Permission is hereby granted for the reproduction of this software, *
4725 * on condition that this copyright notice is included in the reproduction, *
4726 * and that such reproduction is not for purposes of profit or material *
4729 * 27-Aug-1994 Modified for inclusion in perl5 *
4730 * by Charles Bailey bailey@newman.upenn.edu *
4731 *****************************************************************************
4735 * getredirection() is intended to aid in porting C programs
4736 * to VMS (Vax-11 C). The native VMS environment does not support
4737 * '>' and '<' I/O redirection, or command line wild card expansion,
4738 * or a command line pipe mechanism using the '|' AND background
4739 * command execution '&'. All of these capabilities are provided to any
4740 * C program which calls this procedure as the first thing in the
4742 * The piping mechanism will probably work with almost any 'filter' type
4743 * of program. With suitable modification, it may useful for other
4744 * portability problems as well.
4746 * Author: Mark Pizzolato mark@infocomm.com
4750 struct list_item *next;
4754 static void add_item(struct list_item **head,
4755 struct list_item **tail,
4759 static void mp_expand_wild_cards(pTHX_ char *item,
4760 struct list_item **head,
4761 struct list_item **tail,
4764 static int background_process(pTHX_ int argc, char **argv);
4766 static void pipe_and_fork(pTHX_ char **cmargv);
4768 /*{{{ void getredirection(int *ac, char ***av)*/
4770 mp_getredirection(pTHX_ int *ac, char ***av)
4772 * Process vms redirection arg's. Exit if any error is seen.
4773 * If getredirection() processes an argument, it is erased
4774 * from the vector. getredirection() returns a new argc and argv value.
4775 * In the event that a background command is requested (by a trailing "&"),
4776 * this routine creates a background subprocess, and simply exits the program.
4778 * Warning: do not try to simplify the code for vms. The code
4779 * presupposes that getredirection() is called before any data is
4780 * read from stdin or written to stdout.
4782 * Normal usage is as follows:
4788 * getredirection(&argc, &argv);
4792 int argc = *ac; /* Argument Count */
4793 char **argv = *av; /* Argument Vector */
4794 char *ap; /* Argument pointer */
4795 int j; /* argv[] index */
4796 int item_count = 0; /* Count of Items in List */
4797 struct list_item *list_head = 0; /* First Item in List */
4798 struct list_item *list_tail; /* Last Item in List */
4799 char *in = NULL; /* Input File Name */
4800 char *out = NULL; /* Output File Name */
4801 char *outmode = "w"; /* Mode to Open Output File */
4802 char *err = NULL; /* Error File Name */
4803 char *errmode = "w"; /* Mode to Open Error File */
4804 int cmargc = 0; /* Piped Command Arg Count */
4805 char **cmargv = NULL;/* Piped Command Arg Vector */
4808 * First handle the case where the last thing on the line ends with
4809 * a '&'. This indicates the desire for the command to be run in a
4810 * subprocess, so we satisfy that desire.
4813 if (0 == strcmp("&", ap))
4814 exit(background_process(aTHX_ --argc, argv));
4815 if (*ap && '&' == ap[strlen(ap)-1])
4817 ap[strlen(ap)-1] = '\0';
4818 exit(background_process(aTHX_ argc, argv));
4821 * Now we handle the general redirection cases that involve '>', '>>',
4822 * '<', and pipes '|'.
4824 for (j = 0; j < argc; ++j)
4826 if (0 == strcmp("<", argv[j]))
4830 fprintf(stderr,"No input file after < on command line");
4831 exit(LIB$_WRONUMARG);
4836 if ('<' == *(ap = argv[j]))
4841 if (0 == strcmp(">", ap))
4845 fprintf(stderr,"No output file after > on command line");
4846 exit(LIB$_WRONUMARG);
4865 fprintf(stderr,"No output file after > or >> on command line");
4866 exit(LIB$_WRONUMARG);
4870 if (('2' == *ap) && ('>' == ap[1]))
4887 fprintf(stderr,"No output file after 2> or 2>> on command line");
4888 exit(LIB$_WRONUMARG);
4892 if (0 == strcmp("|", argv[j]))
4896 fprintf(stderr,"No command into which to pipe on command line");
4897 exit(LIB$_WRONUMARG);
4899 cmargc = argc-(j+1);
4900 cmargv = &argv[j+1];
4904 if ('|' == *(ap = argv[j]))
4912 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4915 * Allocate and fill in the new argument vector, Some Unix's terminate
4916 * the list with an extra null pointer.
4918 Newx(argv, item_count+1, char *);
4920 for (j = 0; j < item_count; ++j, list_head = list_head->next)
4921 argv[j] = list_head->value;
4927 fprintf(stderr,"'|' and '>' may not both be specified on command line");
4928 exit(LIB$_INVARGORD);
4930 pipe_and_fork(aTHX_ cmargv);
4933 /* Check for input from a pipe (mailbox) */
4935 if (in == NULL && 1 == isapipe(0))
4937 char mbxname[L_tmpnam];
4939 long int dvi_item = DVI$_DEVBUFSIZ;
4940 $DESCRIPTOR(mbxnam, "");
4941 $DESCRIPTOR(mbxdevnam, "");
4943 /* Input from a pipe, reopen it in binary mode to disable */
4944 /* carriage control processing. */
4946 fgetname(stdin, mbxname);
4947 mbxnam.dsc$a_pointer = mbxname;
4948 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4949 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4950 mbxdevnam.dsc$a_pointer = mbxname;
4951 mbxdevnam.dsc$w_length = sizeof(mbxname);
4952 dvi_item = DVI$_DEVNAM;
4953 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4954 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4957 freopen(mbxname, "rb", stdin);
4960 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4964 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4966 fprintf(stderr,"Can't open input file %s as stdin",in);
4969 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4971 fprintf(stderr,"Can't open output file %s as stdout",out);
4974 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4977 if (strcmp(err,"&1") == 0) {
4978 dup2(fileno(stdout), fileno(stderr));
4979 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4982 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4984 fprintf(stderr,"Can't open error file %s as stderr",err);
4988 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4992 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4995 #ifdef ARGPROC_DEBUG
4996 PerlIO_printf(Perl_debug_log, "Arglist:\n");
4997 for (j = 0; j < *ac; ++j)
4998 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
5000 /* Clear errors we may have hit expanding wildcards, so they don't
5001 show up in Perl's $! later */
5002 set_errno(0); set_vaxc_errno(1);
5003 } /* end of getredirection() */
5006 static void add_item(struct list_item **head,
5007 struct list_item **tail,
5013 Newx(*head,1,struct list_item);
5017 Newx((*tail)->next,1,struct list_item);
5018 *tail = (*tail)->next;
5020 (*tail)->value = value;
5024 static void mp_expand_wild_cards(pTHX_ char *item,
5025 struct list_item **head,
5026 struct list_item **tail,
5030 unsigned long int context = 0;
5037 char vmsspec[NAM$C_MAXRSS+1];
5038 $DESCRIPTOR(filespec, "");
5039 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
5040 $DESCRIPTOR(resultspec, "");
5041 unsigned long int zero = 0, sts;
5043 for (cp = item; *cp; cp++) {
5044 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
5045 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
5047 if (!*cp || isspace(*cp))
5049 add_item(head, tail, item, count);
5054 /* "double quoted" wild card expressions pass as is */
5055 /* From DCL that means using e.g.: */
5056 /* perl program """perl.*""" */
5057 item_len = strlen(item);
5058 if ( '"' == *item && '"' == item[item_len-1] )
5061 item[item_len-2] = '\0';
5062 add_item(head, tail, item, count);
5066 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
5067 resultspec.dsc$b_class = DSC$K_CLASS_D;
5068 resultspec.dsc$a_pointer = NULL;
5069 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
5070 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
5071 if (!isunix || !filespec.dsc$a_pointer)
5072 filespec.dsc$a_pointer = item;
5073 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
5075 * Only return version specs, if the caller specified a version
5077 had_version = strchr(item, ';');
5079 * Only return device and directory specs, if the caller specifed either.
5081 had_device = strchr(item, ':');
5082 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
5084 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
5085 &defaultspec, 0, 0, &zero))))
5090 Newx(string,resultspec.dsc$w_length+1,char);
5091 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
5092 string[resultspec.dsc$w_length] = '\0';
5093 if (NULL == had_version)
5094 *(strrchr(string, ';')) = '\0';
5095 if ((!had_directory) && (had_device == NULL))
5097 if (NULL == (devdir = strrchr(string, ']')))
5098 devdir = strrchr(string, '>');
5099 strcpy(string, devdir + 1);
5102 * Be consistent with what the C RTL has already done to the rest of
5103 * the argv items and lowercase all of these names.
5105 if (!decc_efs_case_preserve) {
5106 for (c = string; *c; ++c)
5110 if (isunix) trim_unixpath(string,item,1);
5111 add_item(head, tail, string, count);
5114 if (sts != RMS$_NMF)
5116 set_vaxc_errno(sts);
5119 case RMS$_FNF: case RMS$_DNF:
5120 set_errno(ENOENT); break;
5122 set_errno(ENOTDIR); break;
5124 set_errno(ENODEV); break;
5125 case RMS$_FNM: case RMS$_SYN:
5126 set_errno(EINVAL); break;
5128 set_errno(EACCES); break;
5130 _ckvmssts_noperl(sts);
5134 add_item(head, tail, item, count);
5135 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
5136 _ckvmssts_noperl(lib$find_file_end(&context));
5139 static int child_st[2];/* Event Flag set when child process completes */
5141 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
5143 static unsigned long int exit_handler(int *status)
5147 if (0 == child_st[0])
5149 #ifdef ARGPROC_DEBUG
5150 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
5152 fflush(stdout); /* Have to flush pipe for binary data to */
5153 /* terminate properly -- <tp@mccall.com> */
5154 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
5155 sys$dassgn(child_chan);
5157 sys$synch(0, child_st);
5162 static void sig_child(int chan)
5164 #ifdef ARGPROC_DEBUG
5165 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
5167 if (child_st[0] == 0)
5171 static struct exit_control_block exit_block =
5176 &exit_block.exit_status,
5181 pipe_and_fork(pTHX_ char **cmargv)
5184 struct dsc$descriptor_s *vmscmd;
5185 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
5186 int sts, j, l, ismcr, quote, tquote = 0;
5188 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
5189 vms_execfree(vmscmd);
5194 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
5195 && toupper(*(q+2)) == 'R' && !*(q+3);
5197 while (q && l < MAX_DCL_LINE_LENGTH) {
5199 if (j > 0 && quote) {
5205 if (ismcr && j > 1) quote = 1;
5206 tquote = (strchr(q,' ')) != NULL || *q == '\0';
5209 if (quote || tquote) {
5215 if ((quote||tquote) && *q == '"') {
5225 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
5227 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
5231 static int background_process(pTHX_ int argc, char **argv)
5233 char command[2048] = "$";
5234 $DESCRIPTOR(value, "");
5235 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
5236 static $DESCRIPTOR(null, "NLA0:");
5237 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
5239 $DESCRIPTOR(pidstr, "");
5241 unsigned long int flags = 17, one = 1, retsts;
5243 strcat(command, argv[0]);
5246 strcat(command, " \"");
5247 strcat(command, *(++argv));
5248 strcat(command, "\"");
5250 value.dsc$a_pointer = command;
5251 value.dsc$w_length = strlen(value.dsc$a_pointer);
5252 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
5253 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
5254 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
5255 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
5258 _ckvmssts_noperl(retsts);
5260 #ifdef ARGPROC_DEBUG
5261 PerlIO_printf(Perl_debug_log, "%s\n", command);
5263 sprintf(pidstring, "%08X", pid);
5264 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
5265 pidstr.dsc$a_pointer = pidstring;
5266 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
5267 lib$set_symbol(&pidsymbol, &pidstr);
5271 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
5274 /* OS-specific initialization at image activation (not thread startup) */
5275 /* Older VAXC header files lack these constants */
5276 #ifndef JPI$_RIGHTS_SIZE
5277 # define JPI$_RIGHTS_SIZE 817
5279 #ifndef KGB$M_SUBSYSTEM
5280 # define KGB$M_SUBSYSTEM 0x8
5283 /*{{{void vms_image_init(int *, char ***)*/
5285 vms_image_init(int *argcp, char ***argvp)
5287 char eqv[LNM$C_NAMLENGTH+1] = "";
5288 unsigned int len, tabct = 8, tabidx = 0;
5289 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
5290 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
5291 unsigned short int dummy, rlen;
5292 struct dsc$descriptor_s **tabvec;
5293 #if defined(PERL_IMPLICIT_CONTEXT)
5296 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
5297 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
5298 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
5301 #ifdef KILL_BY_SIGPRC
5302 Perl_csighandler_init();
5305 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
5306 _ckvmssts_noperl(iosb[0]);
5307 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
5308 if (iprv[i]) { /* Running image installed with privs? */
5309 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
5314 /* Rights identifiers might trigger tainting as well. */
5315 if (!will_taint && (rlen || rsz)) {
5316 while (rlen < rsz) {
5317 /* We didn't get all the identifiers on the first pass. Allocate a
5318 * buffer much larger than $GETJPI wants (rsz is size in bytes that
5319 * were needed to hold all identifiers at time of last call; we'll
5320 * allocate that many unsigned long ints), and go back and get 'em.
5321 * If it gave us less than it wanted to despite ample buffer space,
5322 * something's broken. Is your system missing a system identifier?
5324 if (rsz <= jpilist[1].buflen) {
5325 /* Perl_croak accvios when used this early in startup. */
5326 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
5327 rsz, (unsigned long) jpilist[1].buflen,
5328 "Check your rights database for corruption.\n");
5331 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
5332 jpilist[1].bufadr = Newx(mask,rsz,unsigned long int);
5333 jpilist[1].buflen = rsz * sizeof(unsigned long int);
5334 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
5335 _ckvmssts_noperl(iosb[0]);
5337 mask = jpilist[1].bufadr;
5338 /* Check attribute flags for each identifier (2nd longword); protected
5339 * subsystem identifiers trigger tainting.
5341 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
5342 if (mask[i] & KGB$M_SUBSYSTEM) {
5347 if (mask != rlst) Safefree(mask);
5350 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
5351 * logical, some versions of the CRTL will add a phanthom /000000/
5352 * directory. This needs to be removed.
5354 if (decc_filename_unix_report) {
5357 ulen = strlen(argvp[0][0]);
5359 zeros = strstr(argvp[0][0], "/000000/");
5360 if (zeros != NULL) {
5362 mlen = ulen - (zeros - argvp[0][0]) - 7;
5363 memmove(zeros, &zeros[7], mlen);
5365 argvp[0][0][ulen] = '\0';
5368 /* It also may have a trailing dot that needs to be removed otherwise
5369 * it will be converted to VMS mode incorrectly.
5372 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
5373 argvp[0][0][ulen] = '\0';
5376 /* We need to use this hack to tell Perl it should run with tainting,
5377 * since its tainting flag may be part of the PL_curinterp struct, which
5378 * hasn't been allocated when vms_image_init() is called.
5381 char **newargv, **oldargv;
5383 Newx(newargv,(*argcp)+2,char *);
5384 newargv[0] = oldargv[0];
5385 Newx(newargv[1],3,char);
5386 strcpy(newargv[1], "-T");
5387 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
5389 newargv[*argcp] = NULL;
5390 /* We orphan the old argv, since we don't know where it's come from,
5391 * so we don't know how to free it.
5395 else { /* Did user explicitly request tainting? */
5397 char *cp, **av = *argvp;
5398 for (i = 1; i < *argcp; i++) {
5399 if (*av[i] != '-') break;
5400 for (cp = av[i]+1; *cp; cp++) {
5401 if (*cp == 'T') { will_taint = 1; break; }
5402 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
5403 strchr("DFIiMmx",*cp)) break;
5405 if (will_taint) break;
5410 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
5412 if (!tabidx) Newx(tabvec,tabct,struct dsc$descriptor_s *);
5413 else if (tabidx >= tabct) {
5415 Renew(tabvec,tabct,struct dsc$descriptor_s *);
5417 Newx(tabvec[tabidx],1,struct dsc$descriptor_s);
5418 tabvec[tabidx]->dsc$w_length = 0;
5419 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
5420 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
5421 tabvec[tabidx]->dsc$a_pointer = NULL;
5422 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
5424 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
5426 getredirection(argcp,argvp);
5427 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
5429 # include <reentrancy.h>
5430 decc$set_reentrancy(C$C_MULTITHREAD);
5439 * Trim Unix-style prefix off filespec, so it looks like what a shell
5440 * glob expansion would return (i.e. from specified prefix on, not
5441 * full path). Note that returned filespec is Unix-style, regardless
5442 * of whether input filespec was VMS-style or Unix-style.
5444 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
5445 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
5446 * vector of options; at present, only bit 0 is used, and if set tells
5447 * trim unixpath to try the current default directory as a prefix when
5448 * presented with a possibly ambiguous ... wildcard.
5450 * Returns !=0 on success, with trimmed filespec replacing contents of
5451 * fspec, and 0 on failure, with contents of fpsec unchanged.
5453 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
5455 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
5457 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
5458 *template, *base, *end, *cp1, *cp2;
5459 register int tmplen, reslen = 0, dirs = 0;
5461 if (!wildspec || !fspec) return 0;
5462 template = unixwild;
5463 if (strpbrk(wildspec,"]>:") != NULL) {
5464 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
5467 strncpy(unixwild, wildspec, NAM$C_MAXRSS);
5468 unixwild[NAM$C_MAXRSS] = 0;
5470 if (strpbrk(fspec,"]>:") != NULL) {
5471 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
5472 else base = unixified;
5473 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
5474 * check to see that final result fits into (isn't longer than) fspec */
5475 reslen = strlen(fspec);
5479 /* No prefix or absolute path on wildcard, so nothing to remove */
5480 if (!*template || *template == '/') {
5481 if (base == fspec) return 1;
5482 tmplen = strlen(unixified);
5483 if (tmplen > reslen) return 0; /* not enough space */
5484 /* Copy unixified resultant, including trailing NUL */
5485 memmove(fspec,unixified,tmplen+1);
5489 for (end = base; *end; end++) ; /* Find end of resultant filespec */
5490 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
5491 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
5492 for (cp1 = end ;cp1 >= base; cp1--)
5493 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
5495 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
5499 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
5500 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
5501 int ells = 1, totells, segdirs, match;
5502 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
5503 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5505 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
5507 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
5508 if (ellipsis == template && opts & 1) {
5509 /* Template begins with an ellipsis. Since we can't tell how many
5510 * directory names at the front of the resultant to keep for an
5511 * arbitrary starting point, we arbitrarily choose the current
5512 * default directory as a starting point. If it's there as a prefix,
5513 * clip it off. If not, fall through and act as if the leading
5514 * ellipsis weren't there (i.e. return shortest possible path that
5515 * could match template).
5517 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
5518 if (!decc_efs_case_preserve) {
5519 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
5520 if (_tolower(*cp1) != _tolower(*cp2)) break;
5522 segdirs = dirs - totells; /* Min # of dirs we must have left */
5523 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
5524 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
5525 memcpy(fspec,cp2+1,end - cp2);
5529 /* First off, back up over constant elements at end of path */
5531 for (front = end ; front >= base; front--)
5532 if (*front == '/' && !dirs--) { front++; break; }
5534 if (!decc_efs_case_preserve) {
5535 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
5536 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
5538 if (cp1 != '\0') return 0; /* Path too long. */
5540 *cp2 = '\0'; /* Pick up with memcpy later */
5541 lcfront = lcres + (front - base);
5542 /* Now skip over each ellipsis and try to match the path in front of it. */
5544 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
5545 if (*(cp1) == '.' && *(cp1+1) == '.' &&
5546 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
5547 if (cp1 < template) break; /* template started with an ellipsis */
5548 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
5549 ellipsis = cp1; continue;
5551 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
5553 for (segdirs = 0, cp2 = tpl;
5554 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
5556 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
5558 if (!decc_efs_case_preserve) {
5559 *cp2 = _tolower(*cp1); /* else lowercase for match */
5562 *cp2 = *cp1; /* else preserve case for match */
5565 if (*cp2 == '/') segdirs++;
5567 if (cp1 != ellipsis - 1) return 0; /* Path too long */
5568 /* Back up at least as many dirs as in template before matching */
5569 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
5570 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
5571 for (match = 0; cp1 > lcres;) {
5572 resdsc.dsc$a_pointer = cp1;
5573 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
5575 if (match == 1) lcfront = cp1;
5577 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
5579 if (!match) return 0; /* Can't find prefix ??? */
5580 if (match > 1 && opts & 1) {
5581 /* This ... wildcard could cover more than one set of dirs (i.e.
5582 * a set of similar dir names is repeated). If the template
5583 * contains more than 1 ..., upstream elements could resolve the
5584 * ambiguity, but it's not worth a full backtracking setup here.
5585 * As a quick heuristic, clip off the current default directory
5586 * if it's present to find the trimmed spec, else use the
5587 * shortest string that this ... could cover.
5589 char def[NAM$C_MAXRSS+1], *st;
5591 if (getcwd(def, sizeof def,0) == NULL) return 0;
5592 if (!decc_efs_case_preserve) {
5593 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
5594 if (_tolower(*cp1) != _tolower(*cp2)) break;
5596 segdirs = dirs - totells; /* Min # of dirs we must have left */
5597 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
5598 if (*cp1 == '\0' && *cp2 == '/') {
5599 memcpy(fspec,cp2+1,end - cp2);
5602 /* Nope -- stick with lcfront from above and keep going. */
5605 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
5610 } /* end of trim_unixpath() */
5615 * VMS readdir() routines.
5616 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
5618 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
5619 * Minor modifications to original routines.
5622 /* readdir may have been redefined by reentr.h, so make sure we get
5623 * the local version for what we do here.
5628 #if !defined(PERL_IMPLICIT_CONTEXT)
5629 # define readdir Perl_readdir
5631 # define readdir(a) Perl_readdir(aTHX_ a)
5634 /* Number of elements in vms_versions array */
5635 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
5638 * Open a directory, return a handle for later use.
5640 /*{{{ DIR *opendir(char*name) */
5642 Perl_opendir(pTHX_ const char *name)
5645 char dir[NAM$C_MAXRSS+1];
5648 if (do_tovmspath(name,dir,0) == NULL) {
5651 /* Check access before stat; otherwise stat does not
5652 * accurately report whether it's a directory.
5654 if (!cando_by_name(S_IRUSR,0,dir)) {
5655 /* cando_by_name has already set errno */
5658 if (flex_stat(dir,&sb) == -1) return NULL;
5659 if (!S_ISDIR(sb.st_mode)) {
5660 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
5663 /* Get memory for the handle, and the pattern. */
5665 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
5667 /* Fill in the fields; mainly playing with the descriptor. */
5668 sprintf(dd->pattern, "%s*.*",dir);
5671 dd->vms_wantversions = 0;
5672 dd->pat.dsc$a_pointer = dd->pattern;
5673 dd->pat.dsc$w_length = strlen(dd->pattern);
5674 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
5675 dd->pat.dsc$b_class = DSC$K_CLASS_S;
5676 #if defined(USE_ITHREADS)
5677 Newx(dd->mutex,1,perl_mutex);
5678 MUTEX_INIT( (perl_mutex *) dd->mutex );
5684 } /* end of opendir() */
5688 * Set the flag to indicate we want versions or not.
5690 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
5692 vmsreaddirversions(DIR *dd, int flag)
5694 dd->vms_wantversions = flag;
5699 * Free up an opened directory.
5701 /*{{{ void closedir(DIR *dd)*/
5707 sts = lib$find_file_end(&dd->context);
5708 Safefree(dd->pattern);
5709 #if defined(USE_ITHREADS)
5710 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
5711 Safefree(dd->mutex);
5718 * Collect all the version numbers for the current file.
5721 collectversions(pTHX_ DIR *dd)
5723 struct dsc$descriptor_s pat;
5724 struct dsc$descriptor_s res;
5726 char *p, *text, buff[sizeof dd->entry.d_name];
5728 unsigned long context, tmpsts;
5730 /* Convenient shorthand. */
5733 /* Add the version wildcard, ignoring the "*.*" put on before */
5734 i = strlen(dd->pattern);
5735 Newx(text,i + e->d_namlen + 3,char);
5736 strcpy(text, dd->pattern);
5737 sprintf(&text[i - 3], "%s;*", e->d_name);
5739 /* Set up the pattern descriptor. */
5740 pat.dsc$a_pointer = text;
5741 pat.dsc$w_length = i + e->d_namlen - 1;
5742 pat.dsc$b_dtype = DSC$K_DTYPE_T;
5743 pat.dsc$b_class = DSC$K_CLASS_S;
5745 /* Set up result descriptor. */
5746 res.dsc$a_pointer = buff;
5747 res.dsc$w_length = sizeof buff - 2;
5748 res.dsc$b_dtype = DSC$K_DTYPE_T;
5749 res.dsc$b_class = DSC$K_CLASS_S;
5751 /* Read files, collecting versions. */
5752 for (context = 0, e->vms_verscount = 0;
5753 e->vms_verscount < VERSIZE(e);
5754 e->vms_verscount++) {
5755 tmpsts = lib$find_file(&pat, &res, &context);
5756 if (tmpsts == RMS$_NMF || context == 0) break;
5758 buff[sizeof buff - 1] = '\0';
5759 if ((p = strchr(buff, ';')))
5760 e->vms_versions[e->vms_verscount] = atoi(p + 1);
5762 e->vms_versions[e->vms_verscount] = -1;
5765 _ckvmssts(lib$find_file_end(&context));
5768 } /* end of collectversions() */
5771 * Read the next entry from the directory.
5773 /*{{{ struct dirent *readdir(DIR *dd)*/
5775 Perl_readdir(pTHX_ DIR *dd)
5777 struct dsc$descriptor_s res;
5778 char *p, buff[sizeof dd->entry.d_name];
5779 unsigned long int tmpsts;
5781 /* Set up result descriptor, and get next file. */
5782 res.dsc$a_pointer = buff;
5783 res.dsc$w_length = sizeof buff - 2;
5784 res.dsc$b_dtype = DSC$K_DTYPE_T;
5785 res.dsc$b_class = DSC$K_CLASS_S;
5786 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
5787 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
5788 if (!(tmpsts & 1)) {
5789 set_vaxc_errno(tmpsts);
5792 set_errno(EACCES); break;
5794 set_errno(ENODEV); break;
5796 set_errno(ENOTDIR); break;
5797 case RMS$_FNF: case RMS$_DNF:
5798 set_errno(ENOENT); break;
5805 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
5806 if (!decc_efs_case_preserve) {
5807 buff[sizeof buff - 1] = '\0';
5808 for (p = buff; *p; p++) *p = _tolower(*p);
5809 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
5813 /* we don't want to force to lowercase, just null terminate */
5814 buff[res.dsc$w_length] = '\0';
5816 for (p = buff; *p; p++) *p = _tolower(*p);
5817 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
5820 /* Skip any directory component and just copy the name. */
5821 if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1);
5822 else strcpy(dd->entry.d_name, buff);
5824 /* Clobber the version. */
5825 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
5827 dd->entry.d_namlen = strlen(dd->entry.d_name);
5828 dd->entry.vms_verscount = 0;
5829 if (dd->vms_wantversions) collectversions(aTHX_ dd);
5832 } /* end of readdir() */
5836 * Read the next entry from the directory -- thread-safe version.
5838 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
5840 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
5844 MUTEX_LOCK( (perl_mutex *) dd->mutex );
5846 entry = readdir(dd);
5848 retval = ( *result == NULL ? errno : 0 );
5850 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
5854 } /* end of readdir_r() */
5858 * Return something that can be used in a seekdir later.
5860 /*{{{ long telldir(DIR *dd)*/
5869 * Return to a spot where we used to be. Brute force.
5871 /*{{{ void seekdir(DIR *dd,long count)*/
5873 Perl_seekdir(pTHX_ DIR *dd, long count)
5875 int vms_wantversions;
5877 /* If we haven't done anything yet... */
5881 /* Remember some state, and clear it. */
5882 vms_wantversions = dd->vms_wantversions;
5883 dd->vms_wantversions = 0;
5884 _ckvmssts(lib$find_file_end(&dd->context));
5887 /* The increment is in readdir(). */
5888 for (dd->count = 0; dd->count < count; )
5891 dd->vms_wantversions = vms_wantversions;
5893 } /* end of seekdir() */
5896 /* VMS subprocess management
5898 * my_vfork() - just a vfork(), after setting a flag to record that
5899 * the current script is trying a Unix-style fork/exec.
5901 * vms_do_aexec() and vms_do_exec() are called in response to the
5902 * perl 'exec' function. If this follows a vfork call, then they
5903 * call out the regular perl routines in doio.c which do an
5904 * execvp (for those who really want to try this under VMS).
5905 * Otherwise, they do exactly what the perl docs say exec should
5906 * do - terminate the current script and invoke a new command
5907 * (See below for notes on command syntax.)
5909 * do_aspawn() and do_spawn() implement the VMS side of the perl
5910 * 'system' function.
5912 * Note on command arguments to perl 'exec' and 'system': When handled
5913 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
5914 * are concatenated to form a DCL command string. If the first arg
5915 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
5916 * the command string is handed off to DCL directly. Otherwise,
5917 * the first token of the command is taken as the filespec of an image
5918 * to run. The filespec is expanded using a default type of '.EXE' and
5919 * the process defaults for device, directory, etc., and if found, the resultant
5920 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
5921 * the command string as parameters. This is perhaps a bit complicated,
5922 * but I hope it will form a happy medium between what VMS folks expect
5923 * from lib$spawn and what Unix folks expect from exec.
5926 static int vfork_called;
5928 /*{{{int my_vfork()*/
5939 vms_execfree(struct dsc$descriptor_s *vmscmd)
5942 if (vmscmd->dsc$a_pointer) {
5943 Safefree(vmscmd->dsc$a_pointer);
5950 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
5952 char *junk, *tmps = Nullch;
5953 register size_t cmdlen = 0;
5960 tmps = SvPV(really,rlen);
5967 for (idx++; idx <= sp; idx++) {
5969 junk = SvPVx(*idx,rlen);
5970 cmdlen += rlen ? rlen + 1 : 0;
5973 Newx(PL_Cmd,cmdlen+1,char);
5975 if (tmps && *tmps) {
5976 strcpy(PL_Cmd,tmps);
5979 else *PL_Cmd = '\0';
5980 while (++mark <= sp) {
5982 char *s = SvPVx(*mark,n_a);
5984 if (*PL_Cmd) strcat(PL_Cmd," ");
5990 } /* end of setup_argstr() */
5993 static unsigned long int
5994 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
5995 struct dsc$descriptor_s **pvmscmd)
5997 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5998 $DESCRIPTOR(defdsc,".EXE");
5999 $DESCRIPTOR(defdsc2,".");
6000 $DESCRIPTOR(resdsc,resspec);
6001 struct dsc$descriptor_s *vmscmd;
6002 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6003 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
6004 register char *s, *rest, *cp, *wordbreak;
6009 Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
6011 /* Make a copy for modification */
6012 cmdlen = strlen(incmd);
6013 Newx(cmd, cmdlen+1, char);
6014 strncpy(cmd, incmd, cmdlen);
6017 vmscmd->dsc$a_pointer = NULL;
6018 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
6019 vmscmd->dsc$b_class = DSC$K_CLASS_S;
6020 vmscmd->dsc$w_length = 0;
6021 if (pvmscmd) *pvmscmd = vmscmd;
6023 if (suggest_quote) *suggest_quote = 0;
6025 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
6026 return CLI$_BUFOVF; /* continuation lines currently unsupported */
6032 while (*s && isspace(*s)) s++;
6034 if (*s == '@' || *s == '$') {
6035 vmsspec[0] = *s; rest = s + 1;
6036 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
6038 else { cp = vmsspec; rest = s; }
6039 if (*rest == '.' || *rest == '/') {
6042 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
6043 rest++, cp2++) *cp2 = *rest;
6045 if (do_tovmsspec(resspec,cp,0)) {
6048 for (cp2 = vmsspec + strlen(vmsspec);
6049 *rest && cp2 - vmsspec < sizeof vmsspec;
6050 rest++, cp2++) *cp2 = *rest;
6055 /* Intuit whether verb (first word of cmd) is a DCL command:
6056 * - if first nonspace char is '@', it's a DCL indirection
6058 * - if verb contains a filespec separator, it's not a DCL command
6059 * - if it doesn't, caller tells us whether to default to a DCL
6060 * command, or to a local image unless told it's DCL (by leading '$')
6064 if (suggest_quote) *suggest_quote = 1;
6066 register char *filespec = strpbrk(s,":<[.;");
6067 rest = wordbreak = strpbrk(s," \"\t/");
6068 if (!wordbreak) wordbreak = s + strlen(s);
6069 if (*s == '$') check_img = 0;
6070 if (filespec && (filespec < wordbreak)) isdcl = 0;
6071 else isdcl = !check_img;
6075 imgdsc.dsc$a_pointer = s;
6076 imgdsc.dsc$w_length = wordbreak - s;
6077 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
6079 _ckvmssts(lib$find_file_end(&cxt));
6080 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
6081 if (!(retsts & 1) && *s == '$') {
6082 _ckvmssts(lib$find_file_end(&cxt));
6083 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
6084 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
6086 _ckvmssts(lib$find_file_end(&cxt));
6087 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
6091 _ckvmssts(lib$find_file_end(&cxt));
6096 while (*s && !isspace(*s)) s++;
6099 /* check that it's really not DCL with no file extension */
6100 fp = fopen(resspec,"r","ctx=bin","shr=get");
6102 char b[4] = {0,0,0,0};
6103 read(fileno(fp),b,4);
6104 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
6107 if (check_img && isdcl) return RMS$_FNF;
6109 if (cando_by_name(S_IXUSR,0,resspec)) {
6110 Newx(vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
6112 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
6113 if (suggest_quote) *suggest_quote = 1;
6115 strcpy(vmscmd->dsc$a_pointer,"@");
6116 if (suggest_quote) *suggest_quote = 1;
6118 strcat(vmscmd->dsc$a_pointer,resspec);
6119 if (rest) strcat(vmscmd->dsc$a_pointer,rest);
6120 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
6122 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
6124 else retsts = RMS$_PRV;
6127 /* It's either a DCL command or we couldn't find a suitable image */
6128 vmscmd->dsc$w_length = strlen(cmd);
6129 /* if (cmd == PL_Cmd) {
6130 vmscmd->dsc$a_pointer = PL_Cmd;
6131 if (suggest_quote) *suggest_quote = 1;
6134 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
6138 /* check if it's a symbol (for quoting purposes) */
6139 if (suggest_quote && !*suggest_quote) {
6141 char equiv[LNM$C_NAMLENGTH];
6142 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6143 eqvdsc.dsc$a_pointer = equiv;
6145 iss = lib$get_symbol(vmscmd,&eqvdsc);
6146 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
6148 if (!(retsts & 1)) {
6149 /* just hand off status values likely to be due to user error */
6150 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
6151 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
6152 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
6153 else { _ckvmssts(retsts); }
6156 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
6158 } /* end of setup_cmddsc() */
6161 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
6163 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
6166 if (vfork_called) { /* this follows a vfork - act Unixish */
6168 if (vfork_called < 0) {
6169 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
6172 else return do_aexec(really,mark,sp);
6174 /* no vfork - act VMSish */
6175 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
6180 } /* end of vms_do_aexec() */
6183 /* {{{bool vms_do_exec(char *cmd) */
6185 Perl_vms_do_exec(pTHX_ const char *cmd)
6187 struct dsc$descriptor_s *vmscmd;
6189 if (vfork_called) { /* this follows a vfork - act Unixish */
6191 if (vfork_called < 0) {
6192 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
6195 else return do_exec(cmd);
6198 { /* no vfork - act VMSish */
6199 unsigned long int retsts;
6202 TAINT_PROPER("exec");
6203 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
6204 retsts = lib$do_command(vmscmd);
6207 case RMS$_FNF: case RMS$_DNF:
6208 set_errno(ENOENT); break;
6210 set_errno(ENOTDIR); break;
6212 set_errno(ENODEV); break;
6214 set_errno(EACCES); break;
6216 set_errno(EINVAL); break;
6217 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
6218 set_errno(E2BIG); break;
6219 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
6220 _ckvmssts(retsts); /* fall through */
6221 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
6224 set_vaxc_errno(retsts);
6225 if (ckWARN(WARN_EXEC)) {
6226 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
6227 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
6229 vms_execfree(vmscmd);
6234 } /* end of vms_do_exec() */
6237 unsigned long int Perl_do_spawn(pTHX_ const char *);
6239 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
6241 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
6243 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
6246 } /* end of do_aspawn() */
6249 /* {{{unsigned long int do_spawn(char *cmd) */
6251 Perl_do_spawn(pTHX_ const char *cmd)
6253 unsigned long int sts, substs;
6256 TAINT_PROPER("spawn");
6257 if (!cmd || !*cmd) {
6258 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
6261 case RMS$_FNF: case RMS$_DNF:
6262 set_errno(ENOENT); break;
6264 set_errno(ENOTDIR); break;
6266 set_errno(ENODEV); break;
6268 set_errno(EACCES); break;
6270 set_errno(EINVAL); break;
6271 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
6272 set_errno(E2BIG); break;
6273 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
6274 _ckvmssts(sts); /* fall through */
6275 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
6278 set_vaxc_errno(sts);
6279 if (ckWARN(WARN_EXEC)) {
6280 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
6288 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
6293 } /* end of do_spawn() */
6297 static unsigned int *sockflags, sockflagsize;
6300 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
6301 * routines found in some versions of the CRTL can't deal with sockets.
6302 * We don't shim the other file open routines since a socket isn't
6303 * likely to be opened by a name.
6305 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
6306 FILE *my_fdopen(int fd, const char *mode)
6308 FILE *fp = fdopen(fd, mode);
6311 unsigned int fdoff = fd / sizeof(unsigned int);
6312 struct stat sbuf; /* native stat; we don't need flex_stat */
6313 if (!sockflagsize || fdoff > sockflagsize) {
6314 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
6315 else Newx (sockflags,fdoff+2,unsigned int);
6316 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
6317 sockflagsize = fdoff + 2;
6319 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
6320 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
6329 * Clear the corresponding bit when the (possibly) socket stream is closed.
6330 * There still a small hole: we miss an implicit close which might occur
6331 * via freopen(). >> Todo
6333 /*{{{ int my_fclose(FILE *fp)*/
6334 int my_fclose(FILE *fp) {
6336 unsigned int fd = fileno(fp);
6337 unsigned int fdoff = fd / sizeof(unsigned int);
6339 if (sockflagsize && fdoff <= sockflagsize)
6340 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
6348 * A simple fwrite replacement which outputs itmsz*nitm chars without
6349 * introducing record boundaries every itmsz chars.
6350 * We are using fputs, which depends on a terminating null. We may
6351 * well be writing binary data, so we need to accommodate not only
6352 * data with nulls sprinkled in the middle but also data with no null
6355 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
6357 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
6359 register char *cp, *end, *cpd, *data;
6360 register unsigned int fd = fileno(dest);
6361 register unsigned int fdoff = fd / sizeof(unsigned int);
6363 int bufsize = itmsz * nitm + 1;
6365 if (fdoff < sockflagsize &&
6366 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
6367 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
6371 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
6372 memcpy( data, src, itmsz*nitm );
6373 data[itmsz*nitm] = '\0';
6375 end = data + itmsz * nitm;
6376 retval = (int) nitm; /* on success return # items written */
6379 while (cpd <= end) {
6380 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
6381 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
6383 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
6387 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
6390 } /* end of my_fwrite() */
6393 /*{{{ int my_flush(FILE *fp)*/
6395 Perl_my_flush(pTHX_ FILE *fp)
6398 if ((res = fflush(fp)) == 0 && fp) {
6399 #ifdef VMS_DO_SOCKETS
6401 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
6403 res = fsync(fileno(fp));
6406 * If the flush succeeded but set end-of-file, we need to clear
6407 * the error because our caller may check ferror(). BTW, this
6408 * probably means we just flushed an empty file.
6410 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
6417 * Here are replacements for the following Unix routines in the VMS environment:
6418 * getpwuid Get information for a particular UIC or UID
6419 * getpwnam Get information for a named user
6420 * getpwent Get information for each user in the rights database
6421 * setpwent Reset search to the start of the rights database
6422 * endpwent Finish searching for users in the rights database
6424 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
6425 * (defined in pwd.h), which contains the following fields:-
6427 * char *pw_name; Username (in lower case)
6428 * char *pw_passwd; Hashed password
6429 * unsigned int pw_uid; UIC
6430 * unsigned int pw_gid; UIC group number
6431 * char *pw_unixdir; Default device/directory (VMS-style)
6432 * char *pw_gecos; Owner name
6433 * char *pw_dir; Default device/directory (Unix-style)
6434 * char *pw_shell; Default CLI name (eg. DCL)
6436 * If the specified user does not exist, getpwuid and getpwnam return NULL.
6438 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
6439 * not the UIC member number (eg. what's returned by getuid()),
6440 * getpwuid() can accept either as input (if uid is specified, the caller's
6441 * UIC group is used), though it won't recognise gid=0.
6443 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
6444 * information about other users in your group or in other groups, respectively.
6445 * If the required privilege is not available, then these routines fill only
6446 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
6449 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
6452 /* sizes of various UAF record fields */
6453 #define UAI$S_USERNAME 12
6454 #define UAI$S_IDENT 31
6455 #define UAI$S_OWNER 31
6456 #define UAI$S_DEFDEV 31
6457 #define UAI$S_DEFDIR 63
6458 #define UAI$S_DEFCLI 31
6461 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
6462 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
6463 (uic).uic$v_group != UIC$K_WILD_GROUP)
6465 static char __empty[]= "";
6466 static struct passwd __passwd_empty=
6467 {(char *) __empty, (char *) __empty, 0, 0,
6468 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
6469 static int contxt= 0;
6470 static struct passwd __pwdcache;
6471 static char __pw_namecache[UAI$S_IDENT+1];
6474 * This routine does most of the work extracting the user information.
6476 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
6479 unsigned char length;
6480 char pw_gecos[UAI$S_OWNER+1];
6482 static union uicdef uic;
6484 unsigned char length;
6485 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
6488 unsigned char length;
6489 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
6492 unsigned char length;
6493 char pw_shell[UAI$S_DEFCLI+1];
6495 static char pw_passwd[UAI$S_PWD+1];
6497 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
6498 struct dsc$descriptor_s name_desc;
6499 unsigned long int sts;
6501 static struct itmlst_3 itmlst[]= {
6502 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
6503 {sizeof(uic), UAI$_UIC, &uic, &luic},
6504 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
6505 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
6506 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
6507 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
6508 {0, 0, NULL, NULL}};
6510 name_desc.dsc$w_length= strlen(name);
6511 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
6512 name_desc.dsc$b_class= DSC$K_CLASS_S;
6513 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
6515 /* Note that sys$getuai returns many fields as counted strings. */
6516 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
6517 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
6518 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
6520 else { _ckvmssts(sts); }
6521 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
6523 if ((int) owner.length < lowner) lowner= (int) owner.length;
6524 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
6525 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
6526 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
6527 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
6528 owner.pw_gecos[lowner]= '\0';
6529 defdev.pw_dir[ldefdev+ldefdir]= '\0';
6530 defcli.pw_shell[ldefcli]= '\0';
6531 if (valid_uic(uic)) {
6532 pwd->pw_uid= uic.uic$l_uic;
6533 pwd->pw_gid= uic.uic$v_group;
6536 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
6537 pwd->pw_passwd= pw_passwd;
6538 pwd->pw_gecos= owner.pw_gecos;
6539 pwd->pw_dir= defdev.pw_dir;
6540 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
6541 pwd->pw_shell= defcli.pw_shell;
6542 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
6544 ldir= strlen(pwd->pw_unixdir) - 1;
6545 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
6548 strcpy(pwd->pw_unixdir, pwd->pw_dir);
6549 if (!decc_efs_case_preserve)
6550 __mystrtolower(pwd->pw_unixdir);
6555 * Get information for a named user.
6557 /*{{{struct passwd *getpwnam(char *name)*/
6558 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
6560 struct dsc$descriptor_s name_desc;
6562 unsigned long int status, sts;
6564 __pwdcache = __passwd_empty;
6565 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
6566 /* We still may be able to determine pw_uid and pw_gid */
6567 name_desc.dsc$w_length= strlen(name);
6568 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
6569 name_desc.dsc$b_class= DSC$K_CLASS_S;
6570 name_desc.dsc$a_pointer= (char *) name;
6571 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
6572 __pwdcache.pw_uid= uic.uic$l_uic;
6573 __pwdcache.pw_gid= uic.uic$v_group;
6576 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
6577 set_vaxc_errno(sts);
6578 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
6581 else { _ckvmssts(sts); }
6584 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
6585 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
6586 __pwdcache.pw_name= __pw_namecache;
6588 } /* end of my_getpwnam() */
6592 * Get information for a particular UIC or UID.
6593 * Called by my_getpwent with uid=-1 to list all users.
6595 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
6596 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
6598 const $DESCRIPTOR(name_desc,__pw_namecache);
6599 unsigned short lname;
6601 unsigned long int status;
6603 if (uid == (unsigned int) -1) {
6605 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
6606 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
6607 set_vaxc_errno(status);
6608 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
6612 else { _ckvmssts(status); }
6613 } while (!valid_uic (uic));
6617 if (!uic.uic$v_group)
6618 uic.uic$v_group= PerlProc_getgid();
6620 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
6621 else status = SS$_IVIDENT;
6622 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
6623 status == RMS$_PRV) {
6624 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
6627 else { _ckvmssts(status); }
6629 __pw_namecache[lname]= '\0';
6630 __mystrtolower(__pw_namecache);
6632 __pwdcache = __passwd_empty;
6633 __pwdcache.pw_name = __pw_namecache;
6635 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
6636 The identifier's value is usually the UIC, but it doesn't have to be,
6637 so if we can, we let fillpasswd update this. */
6638 __pwdcache.pw_uid = uic.uic$l_uic;
6639 __pwdcache.pw_gid = uic.uic$v_group;
6641 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
6644 } /* end of my_getpwuid() */
6648 * Get information for next user.
6650 /*{{{struct passwd *my_getpwent()*/
6651 struct passwd *Perl_my_getpwent(pTHX)
6653 return (my_getpwuid((unsigned int) -1));
6658 * Finish searching rights database for users.
6660 /*{{{void my_endpwent()*/
6661 void Perl_my_endpwent(pTHX)
6664 _ckvmssts(sys$finish_rdb(&contxt));
6670 #ifdef HOMEGROWN_POSIX_SIGNALS
6671 /* Signal handling routines, pulled into the core from POSIX.xs.
6673 * We need these for threads, so they've been rolled into the core,
6674 * rather than left in POSIX.xs.
6676 * (DRS, Oct 23, 1997)
6679 /* sigset_t is atomic under VMS, so these routines are easy */
6680 /*{{{int my_sigemptyset(sigset_t *) */
6681 int my_sigemptyset(sigset_t *set) {
6682 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6688 /*{{{int my_sigfillset(sigset_t *)*/
6689 int my_sigfillset(sigset_t *set) {
6691 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6692 for (i = 0; i < NSIG; i++) *set |= (1 << i);
6698 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
6699 int my_sigaddset(sigset_t *set, int sig) {
6700 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6701 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
6702 *set |= (1 << (sig - 1));
6708 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
6709 int my_sigdelset(sigset_t *set, int sig) {
6710 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6711 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
6712 *set &= ~(1 << (sig - 1));
6718 /*{{{int my_sigismember(sigset_t *set, int sig)*/
6719 int my_sigismember(sigset_t *set, int sig) {
6720 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
6721 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
6722 return *set & (1 << (sig - 1));
6727 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
6728 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
6731 /* If set and oset are both null, then things are badly wrong. Bail out. */
6732 if ((oset == NULL) && (set == NULL)) {
6733 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
6737 /* If set's null, then we're just handling a fetch. */
6739 tempmask = sigblock(0);
6744 tempmask = sigsetmask(*set);
6747 tempmask = sigblock(*set);
6750 tempmask = sigblock(0);
6751 sigsetmask(*oset & ~tempmask);
6754 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6759 /* Did they pass us an oset? If so, stick our holding mask into it */
6766 #endif /* HOMEGROWN_POSIX_SIGNALS */
6769 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
6770 * my_utime(), and flex_stat(), all of which operate on UTC unless
6771 * VMSISH_TIMES is true.
6773 /* method used to handle UTC conversions:
6774 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
6776 static int gmtime_emulation_type;
6777 /* number of secs to add to UTC POSIX-style time to get local time */
6778 static long int utc_offset_secs;
6780 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
6781 * in vmsish.h. #undef them here so we can call the CRTL routines
6790 * DEC C previous to 6.0 corrupts the behavior of the /prefix
6791 * qualifier with the extern prefix pragma. This provisional
6792 * hack circumvents this prefix pragma problem in previous
6795 #if defined(__VMS_VER) && __VMS_VER >= 70000000
6796 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
6797 # pragma __extern_prefix save
6798 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
6799 # define gmtime decc$__utctz_gmtime
6800 # define localtime decc$__utctz_localtime
6801 # define time decc$__utc_time
6802 # pragma __extern_prefix restore
6804 struct tm *gmtime(), *localtime();
6810 static time_t toutc_dst(time_t loc) {
6813 if ((rsltmp = localtime(&loc)) == NULL) return -1;
6814 loc -= utc_offset_secs;
6815 if (rsltmp->tm_isdst) loc -= 3600;
6818 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
6819 ((gmtime_emulation_type || my_time(NULL)), \
6820 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
6821 ((secs) - utc_offset_secs))))
6823 static time_t toloc_dst(time_t utc) {
6826 utc += utc_offset_secs;
6827 if ((rsltmp = localtime(&utc)) == NULL) return -1;
6828 if (rsltmp->tm_isdst) utc += 3600;
6831 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
6832 ((gmtime_emulation_type || my_time(NULL)), \
6833 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
6834 ((secs) + utc_offset_secs))))
6836 #ifndef RTL_USES_UTC
6839 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
6840 DST starts on 1st sun of april at 02:00 std time
6841 ends on last sun of october at 02:00 dst time
6842 see the UCX management command reference, SET CONFIG TIMEZONE
6843 for formatting info.
6845 No, it's not as general as it should be, but then again, NOTHING
6846 will handle UK times in a sensible way.
6851 parse the DST start/end info:
6852 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
6856 tz_parse_startend(char *s, struct tm *w, int *past)
6858 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
6859 int ly, dozjd, d, m, n, hour, min, sec, j, k;
6864 if (!past) return 0;
6867 if (w->tm_year % 4 == 0) ly = 1;
6868 if (w->tm_year % 100 == 0) ly = 0;
6869 if (w->tm_year+1900 % 400 == 0) ly = 1;
6872 dozjd = isdigit(*s);
6873 if (*s == 'J' || *s == 'j' || dozjd) {
6874 if (!dozjd && !isdigit(*++s)) return 0;
6877 d = d*10 + *s++ - '0';
6879 d = d*10 + *s++ - '0';
6882 if (d == 0) return 0;
6883 if (d > 366) return 0;
6885 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
6888 } else if (*s == 'M' || *s == 'm') {
6889 if (!isdigit(*++s)) return 0;
6891 if (isdigit(*s)) m = 10*m + *s++ - '0';
6892 if (*s != '.') return 0;
6893 if (!isdigit(*++s)) return 0;
6895 if (n < 1 || n > 5) return 0;
6896 if (*s != '.') return 0;
6897 if (!isdigit(*++s)) return 0;
6899 if (d > 6) return 0;
6903 if (!isdigit(*++s)) return 0;
6905 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
6907 if (!isdigit(*++s)) return 0;
6909 if (isdigit(*s)) min = 10*min + *s++ - '0';
6911 if (!isdigit(*++s)) return 0;
6913 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
6923 if (w->tm_yday < d) goto before;
6924 if (w->tm_yday > d) goto after;
6926 if (w->tm_mon+1 < m) goto before;
6927 if (w->tm_mon+1 > m) goto after;
6929 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
6930 k = d - j; /* mday of first d */
6932 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
6933 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
6934 if (w->tm_mday < k) goto before;
6935 if (w->tm_mday > k) goto after;
6938 if (w->tm_hour < hour) goto before;
6939 if (w->tm_hour > hour) goto after;
6940 if (w->tm_min < min) goto before;
6941 if (w->tm_min > min) goto after;
6942 if (w->tm_sec < sec) goto before;
6956 /* parse the offset: (+|-)hh[:mm[:ss]] */
6959 tz_parse_offset(char *s, int *offset)
6961 int hour = 0, min = 0, sec = 0;
6964 if (!offset) return 0;
6966 if (*s == '-') {neg++; s++;}
6968 if (!isdigit(*s)) return 0;
6970 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
6971 if (hour > 24) return 0;
6973 if (!isdigit(*++s)) return 0;
6975 if (isdigit(*s)) min = min*10 + (*s++ - '0');
6976 if (min > 59) return 0;
6978 if (!isdigit(*++s)) return 0;
6980 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
6981 if (sec > 59) return 0;
6985 *offset = (hour*60+min)*60 + sec;
6986 if (neg) *offset = -*offset;
6991 input time is w, whatever type of time the CRTL localtime() uses.
6992 sets dst, the zone, and the gmtoff (seconds)
6994 caches the value of TZ and UCX$TZ env variables; note that
6995 my_setenv looks for these and sets a flag if they're changed
6998 We have to watch out for the "australian" case (dst starts in
6999 october, ends in april)...flagged by "reverse" and checked by
7000 scanning through the months of the previous year.
7005 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
7010 char *dstzone, *tz, *s_start, *s_end;
7011 int std_off, dst_off, isdst;
7012 int y, dststart, dstend;
7013 static char envtz[1025]; /* longer than any logical, symbol, ... */
7014 static char ucxtz[1025];
7015 static char reversed = 0;
7021 reversed = -1; /* flag need to check */
7022 envtz[0] = ucxtz[0] = '\0';
7023 tz = my_getenv("TZ",0);
7024 if (tz) strcpy(envtz, tz);
7025 tz = my_getenv("UCX$TZ",0);
7026 if (tz) strcpy(ucxtz, tz);
7027 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
7030 if (!*tz) tz = ucxtz;
7033 while (isalpha(*s)) s++;
7034 s = tz_parse_offset(s, &std_off);
7036 if (!*s) { /* no DST, hurray we're done! */
7042 while (isalpha(*s)) s++;
7043 s2 = tz_parse_offset(s, &dst_off);
7047 dst_off = std_off - 3600;
7050 if (!*s) { /* default dst start/end?? */
7051 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
7052 s = strchr(ucxtz,',');
7054 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
7056 if (*s != ',') return 0;
7059 when = _toutc(when); /* convert to utc */
7060 when = when - std_off; /* convert to pseudolocal time*/
7062 w2 = localtime(&when);
7065 s = tz_parse_startend(s_start,w2,&dststart);
7067 if (*s != ',') return 0;
7070 when = _toutc(when); /* convert to utc */
7071 when = when - dst_off; /* convert to pseudolocal time*/
7072 w2 = localtime(&when);
7073 if (w2->tm_year != y) { /* spans a year, just check one time */
7074 when += dst_off - std_off;
7075 w2 = localtime(&when);
7078 s = tz_parse_startend(s_end,w2,&dstend);
7081 if (reversed == -1) { /* need to check if start later than end */
7085 if (when < 2*365*86400) {
7086 when += 2*365*86400;
7090 w2 =localtime(&when);
7091 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
7093 for (j = 0; j < 12; j++) {
7094 w2 =localtime(&when);
7095 tz_parse_startend(s_start,w2,&ds);
7096 tz_parse_startend(s_end,w2,&de);
7097 if (ds != de) break;
7101 if (de && !ds) reversed = 1;
7104 isdst = dststart && !dstend;
7105 if (reversed) isdst = dststart || !dstend;
7108 if (dst) *dst = isdst;
7109 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
7110 if (isdst) tz = dstzone;
7112 while(isalpha(*tz)) *zone++ = *tz++;
7118 #endif /* !RTL_USES_UTC */
7120 /* my_time(), my_localtime(), my_gmtime()
7121 * By default traffic in UTC time values, using CRTL gmtime() or
7122 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
7123 * Note: We need to use these functions even when the CRTL has working
7124 * UTC support, since they also handle C<use vmsish qw(times);>
7126 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
7127 * Modified by Charles Bailey <bailey@newman.upenn.edu>
7130 /*{{{time_t my_time(time_t *timep)*/
7131 time_t Perl_my_time(pTHX_ time_t *timep)
7136 if (gmtime_emulation_type == 0) {
7138 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
7139 /* results of calls to gmtime() and localtime() */
7140 /* for same &base */
7142 gmtime_emulation_type++;
7143 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
7144 char off[LNM$C_NAMLENGTH+1];;
7146 gmtime_emulation_type++;
7147 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
7148 gmtime_emulation_type++;
7149 utc_offset_secs = 0;
7150 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
7152 else { utc_offset_secs = atol(off); }
7154 else { /* We've got a working gmtime() */
7155 struct tm gmt, local;
7158 tm_p = localtime(&base);
7160 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
7161 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
7162 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
7163 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
7169 # ifdef RTL_USES_UTC
7170 if (VMSISH_TIME) when = _toloc(when);
7172 if (!VMSISH_TIME) when = _toutc(when);
7175 if (timep != NULL) *timep = when;
7178 } /* end of my_time() */
7182 /*{{{struct tm *my_gmtime(const time_t *timep)*/
7184 Perl_my_gmtime(pTHX_ const time_t *timep)
7190 if (timep == NULL) {
7191 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7194 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
7198 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
7200 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
7201 return gmtime(&when);
7203 /* CRTL localtime() wants local time as input, so does no tz correction */
7204 rsltmp = localtime(&when);
7205 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
7208 } /* end of my_gmtime() */
7212 /*{{{struct tm *my_localtime(const time_t *timep)*/
7214 Perl_my_localtime(pTHX_ const time_t *timep)
7216 time_t when, whenutc;
7220 if (timep == NULL) {
7221 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7224 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
7225 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
7228 # ifdef RTL_USES_UTC
7230 if (VMSISH_TIME) when = _toutc(when);
7232 /* CRTL localtime() wants UTC as input, does tz correction itself */
7233 return localtime(&when);
7235 # else /* !RTL_USES_UTC */
7238 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
7239 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
7242 #ifndef RTL_USES_UTC
7243 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
7244 when = whenutc - offset; /* pseudolocal time*/
7247 /* CRTL localtime() wants local time as input, so does no tz correction */
7248 rsltmp = localtime(&when);
7249 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
7253 } /* end of my_localtime() */
7256 /* Reset definitions for later calls */
7257 #define gmtime(t) my_gmtime(t)
7258 #define localtime(t) my_localtime(t)
7259 #define time(t) my_time(t)
7262 /* my_utime - update modification time of a file
7263 * calling sequence is identical to POSIX utime(), but under
7264 * VMS only the modification time is changed; ODS-2 does not
7265 * maintain access times. Restrictions differ from the POSIX
7266 * definition in that the time can be changed as long as the
7267 * caller has permission to execute the necessary IO$_MODIFY $QIO;
7268 * no separate checks are made to insure that the caller is the
7269 * owner of the file or has special privs enabled.
7270 * Code here is based on Joe Meadows' FILE utility.
7273 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
7274 * to VMS epoch (01-JAN-1858 00:00:00.00)
7275 * in 100 ns intervals.
7277 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
7279 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
7280 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
7284 long int bintime[2], len = 2, lowbit, unixtime,
7285 secscale = 10000000; /* seconds --> 100 ns intervals */
7286 unsigned long int chan, iosb[2], retsts;
7287 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
7288 struct FAB myfab = cc$rms_fab;
7289 struct NAM mynam = cc$rms_nam;
7290 #if defined (__DECC) && defined (__VAX)
7291 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
7292 * at least through VMS V6.1, which causes a type-conversion warning.
7294 # pragma message save
7295 # pragma message disable cvtdiftypes
7297 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
7298 struct fibdef myfib;
7299 #if defined (__DECC) && defined (__VAX)
7300 /* This should be right after the declaration of myatr, but due
7301 * to a bug in VAX DEC C, this takes effect a statement early.
7303 # pragma message restore
7305 /* cast ok for read only parameter */
7306 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
7307 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
7308 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
7310 if (file == NULL || *file == '\0') {
7312 set_vaxc_errno(LIB$_INVARG);
7315 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
7317 if (utimes != NULL) {
7318 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
7319 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
7320 * Since time_t is unsigned long int, and lib$emul takes a signed long int
7321 * as input, we force the sign bit to be clear by shifting unixtime right
7322 * one bit, then multiplying by an extra factor of 2 in lib$emul().
7324 lowbit = (utimes->modtime & 1) ? secscale : 0;
7325 unixtime = (long int) utimes->modtime;
7327 /* If input was UTC; convert to local for sys svc */
7328 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
7330 unixtime >>= 1; secscale <<= 1;
7331 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
7332 if (!(retsts & 1)) {
7334 set_vaxc_errno(retsts);
7337 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
7338 if (!(retsts & 1)) {
7340 set_vaxc_errno(retsts);
7345 /* Just get the current time in VMS format directly */
7346 retsts = sys$gettim(bintime);
7347 if (!(retsts & 1)) {
7349 set_vaxc_errno(retsts);
7354 myfab.fab$l_fna = vmsspec;
7355 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
7356 myfab.fab$l_nam = &mynam;
7357 mynam.nam$l_esa = esa;
7358 mynam.nam$b_ess = (unsigned char) sizeof esa;
7359 mynam.nam$l_rsa = rsa;
7360 mynam.nam$b_rss = (unsigned char) sizeof rsa;
7361 if (decc_efs_case_preserve)
7362 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
7364 /* Look for the file to be affected, letting RMS parse the file
7365 * specification for us as well. I have set errno using only
7366 * values documented in the utime() man page for VMS POSIX.
7368 retsts = sys$parse(&myfab,0,0);
7369 if (!(retsts & 1)) {
7370 set_vaxc_errno(retsts);
7371 if (retsts == RMS$_PRV) set_errno(EACCES);
7372 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
7373 else set_errno(EVMSERR);
7376 retsts = sys$search(&myfab,0,0);
7377 if (!(retsts & 1)) {
7378 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
7379 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
7380 set_vaxc_errno(retsts);
7381 if (retsts == RMS$_PRV) set_errno(EACCES);
7382 else if (retsts == RMS$_FNF) set_errno(ENOENT);
7383 else set_errno(EVMSERR);
7387 devdsc.dsc$w_length = mynam.nam$b_dev;
7388 /* cast ok for read only parameter */
7389 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
7391 retsts = sys$assign(&devdsc,&chan,0,0);
7392 if (!(retsts & 1)) {
7393 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
7394 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
7395 set_vaxc_errno(retsts);
7396 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
7397 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
7398 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
7399 else set_errno(EVMSERR);
7403 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
7404 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
7406 memset((void *) &myfib, 0, sizeof myfib);
7407 #if defined(__DECC) || defined(__DECCXX)
7408 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
7409 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
7410 /* This prevents the revision time of the file being reset to the current
7411 * time as a result of our IO$_MODIFY $QIO. */
7412 myfib.fib$l_acctl = FIB$M_NORECORD;
7414 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
7415 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
7416 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
7418 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
7419 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
7420 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
7421 _ckvmssts(sys$dassgn(chan));
7422 if (retsts & 1) retsts = iosb[0];
7423 if (!(retsts & 1)) {
7424 set_vaxc_errno(retsts);
7425 if (retsts == SS$_NOPRIV) set_errno(EACCES);
7426 else set_errno(EVMSERR);
7431 } /* end of my_utime() */
7435 * flex_stat, flex_fstat
7436 * basic stat, but gets it right when asked to stat
7437 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
7440 /* encode_dev packs a VMS device name string into an integer to allow
7441 * simple comparisons. This can be used, for example, to check whether two
7442 * files are located on the same device, by comparing their encoded device
7443 * names. Even a string comparison would not do, because stat() reuses the
7444 * device name buffer for each call; so without encode_dev, it would be
7445 * necessary to save the buffer and use strcmp (this would mean a number of
7446 * changes to the standard Perl code, to say nothing of what a Perl script
7449 * The device lock id, if it exists, should be unique (unless perhaps compared
7450 * with lock ids transferred from other nodes). We have a lock id if the disk is
7451 * mounted cluster-wide, which is when we tend to get long (host-qualified)
7452 * device names. Thus we use the lock id in preference, and only if that isn't
7453 * available, do we try to pack the device name into an integer (flagged by
7454 * the sign bit (LOCKID_MASK) being set).
7456 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
7457 * name and its encoded form, but it seems very unlikely that we will find
7458 * two files on different disks that share the same encoded device names,
7459 * and even more remote that they will share the same file id (if the test
7460 * is to check for the same file).
7462 * A better method might be to use sys$device_scan on the first call, and to
7463 * search for the device, returning an index into the cached array.
7464 * The number returned would be more intelligable.
7465 * This is probably not worth it, and anyway would take quite a bit longer
7466 * on the first call.
7468 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
7469 static mydev_t encode_dev (pTHX_ const char *dev)
7472 unsigned long int f;
7477 if (!dev || !dev[0]) return 0;
7481 struct dsc$descriptor_s dev_desc;
7482 unsigned long int status, lockid, item = DVI$_LOCKID;
7484 /* For cluster-mounted disks, the disk lock identifier is unique, so we
7485 can try that first. */
7486 dev_desc.dsc$w_length = strlen (dev);
7487 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
7488 dev_desc.dsc$b_class = DSC$K_CLASS_S;
7489 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
7490 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
7491 if (lockid) return (lockid & ~LOCKID_MASK);
7495 /* Otherwise we try to encode the device name */
7499 for (q = dev + strlen(dev); q--; q >= dev) {
7502 else if (isalpha (toupper (*q)))
7503 c= toupper (*q) - 'A' + (char)10;
7505 continue; /* Skip '$'s */
7507 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
7509 enc += f * (unsigned long int) c;
7511 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
7513 } /* end of encode_dev() */
7515 static char namecache[NAM$C_MAXRSS+1];
7518 is_null_device(name)
7521 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
7522 The underscore prefix, controller letter, and unit number are
7523 independently optional; for our purposes, the colon punctuation
7524 is not. The colon can be trailed by optional directory and/or
7525 filename, but two consecutive colons indicates a nodename rather
7526 than a device. [pr] */
7527 if (*name == '_') ++name;
7528 if (tolower(*name++) != 'n') return 0;
7529 if (tolower(*name++) != 'l') return 0;
7530 if (tolower(*name) == 'a') ++name;
7531 if (*name == '0') ++name;
7532 return (*name++ == ':') && (*name != ':');
7535 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
7536 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
7537 * subset of the applicable information.
7540 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, const Stat_t *statbufp)
7542 char fname_phdev[NAM$C_MAXRSS+1];
7543 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
7545 char fname[NAM$C_MAXRSS+1];
7546 unsigned long int retsts;
7547 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7548 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7550 /* If the struct mystat is stale, we're OOL; stat() overwrites the
7551 device name on successive calls */
7552 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
7553 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
7554 namdsc.dsc$a_pointer = fname;
7555 namdsc.dsc$w_length = sizeof fname - 1;
7557 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
7558 &namdsc,&namdsc.dsc$w_length,0,0);
7560 fname[namdsc.dsc$w_length] = '\0';
7562 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
7563 * but if someone has redefined that logical, Perl gets very lost. Since
7564 * we have the physical device name from the stat buffer, just paste it on.
7566 strcpy( fname_phdev, statbufp->st_devnam );
7567 strcat( fname_phdev, strrchr(fname, ':') );
7569 return cando_by_name(bit,effective,fname_phdev);
7571 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
7572 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
7576 return FALSE; /* Should never get to here */
7578 } /* end of cando() */
7582 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
7584 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, const char *fname)
7586 static char usrname[L_cuserid];
7587 static struct dsc$descriptor_s usrdsc =
7588 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
7589 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
7590 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
7591 unsigned short int retlen, trnlnm_iter_count;
7592 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7593 union prvdef curprv;
7594 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
7595 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
7596 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
7597 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
7599 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
7601 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7603 if (!fname || !*fname) return FALSE;
7604 /* Make sure we expand logical names, since sys$check_access doesn't */
7605 if (!strpbrk(fname,"/]>:")) {
7606 strcpy(fileified,fname);
7607 trnlnm_iter_count = 0;
7608 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
7609 trnlnm_iter_count++;
7610 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
7614 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
7615 retlen = namdsc.dsc$w_length = strlen(vmsname);
7616 namdsc.dsc$a_pointer = vmsname;
7617 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
7618 vmsname[retlen-1] == ':') {
7619 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
7620 namdsc.dsc$w_length = strlen(fileified);
7621 namdsc.dsc$a_pointer = fileified;
7625 case S_IXUSR: case S_IXGRP: case S_IXOTH:
7626 access = ARM$M_EXECUTE; break;
7627 case S_IRUSR: case S_IRGRP: case S_IROTH:
7628 access = ARM$M_READ; break;
7629 case S_IWUSR: case S_IWGRP: case S_IWOTH:
7630 access = ARM$M_WRITE; break;
7631 case S_IDUSR: case S_IDGRP: case S_IDOTH:
7632 access = ARM$M_DELETE; break;
7637 /* Before we call $check_access, create a user profile with the current
7638 * process privs since otherwise it just uses the default privs from the
7639 * UAF and might give false positives or negatives. This only works on
7640 * VMS versions v6.0 and later since that's when sys$create_user_profile
7644 /* get current process privs and username */
7645 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
7648 #if defined(__VMS_VER) && __VMS_VER >= 60000000
7650 /* find out the space required for the profile */
7651 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
7652 &usrprodsc.dsc$w_length,0));
7654 /* allocate space for the profile and get it filled in */
7655 Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
7656 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
7657 &usrprodsc.dsc$w_length,0));
7659 /* use the profile to check access to the file; free profile & analyze results */
7660 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
7661 Safefree(usrprodsc.dsc$a_pointer);
7662 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
7666 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
7670 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
7671 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
7672 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
7673 set_vaxc_errno(retsts);
7674 if (retsts == SS$_NOPRIV) set_errno(EACCES);
7675 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
7676 else set_errno(ENOENT);
7679 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
7684 return FALSE; /* Should never get here */
7686 } /* end of cando_by_name() */
7690 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
7692 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
7694 if (!fstat(fd,(stat_t *) statbufp)) {
7695 if (statbufp == (Stat_t *) &PL_statcache) {
7698 /* Save name for cando by name in VMS format */
7699 cptr = getname(fd, namecache, 1);
7701 /* This should not happen, but just in case */
7703 namecache[0] = '\0';
7705 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
7706 # ifdef RTL_USES_UTC
7709 statbufp->st_mtime = _toloc(statbufp->st_mtime);
7710 statbufp->st_atime = _toloc(statbufp->st_atime);
7711 statbufp->st_ctime = _toloc(statbufp->st_ctime);
7716 if (!VMSISH_TIME) { /* Return UTC instead of local time */
7720 statbufp->st_mtime = _toutc(statbufp->st_mtime);
7721 statbufp->st_atime = _toutc(statbufp->st_atime);
7722 statbufp->st_ctime = _toutc(statbufp->st_ctime);
7729 } /* end of flex_fstat() */
7732 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
7734 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
7736 char fileified[NAM$C_MAXRSS+1];
7737 char temp_fspec[NAM$C_MAXRSS+300];
7739 int saved_errno, saved_vaxc_errno;
7741 if (!fspec) return retval;
7742 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
7743 strcpy(temp_fspec, fspec);
7744 if (statbufp == (Stat_t *) &PL_statcache)
7745 do_tovmsspec(temp_fspec,namecache,0);
7746 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
7747 memset(statbufp,0,sizeof *statbufp);
7748 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
7749 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
7750 statbufp->st_uid = 0x00010001;
7751 statbufp->st_gid = 0x0001;
7752 time((time_t *)&statbufp->st_mtime);
7753 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
7757 /* Try for a directory name first. If fspec contains a filename without
7758 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
7759 * and sea:[wine.dark]water. exist, we prefer the directory here.
7760 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
7761 * not sea:[wine.dark]., if the latter exists. If the intended target is
7762 * the file with null type, specify this by calling flex_stat() with
7763 * a '.' at the end of fspec.
7765 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
7766 retval = stat(fileified,(stat_t *) statbufp);
7767 if (!retval && statbufp == (Stat_t *) &PL_statcache)
7768 strcpy(namecache,fileified);
7770 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
7772 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
7773 # ifdef RTL_USES_UTC
7776 statbufp->st_mtime = _toloc(statbufp->st_mtime);
7777 statbufp->st_atime = _toloc(statbufp->st_atime);
7778 statbufp->st_ctime = _toloc(statbufp->st_ctime);
7783 if (!VMSISH_TIME) { /* Return UTC instead of local time */
7787 statbufp->st_mtime = _toutc(statbufp->st_mtime);
7788 statbufp->st_atime = _toutc(statbufp->st_atime);
7789 statbufp->st_ctime = _toutc(statbufp->st_ctime);
7793 /* If we were successful, leave errno where we found it */
7794 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
7797 } /* end of flex_stat() */
7801 /*{{{char *my_getlogin()*/
7802 /* VMS cuserid == Unix getlogin, except calling sequence */
7806 static char user[L_cuserid];
7807 return cuserid(user);
7812 /* rmscopy - copy a file using VMS RMS routines
7814 * Copies contents and attributes of spec_in to spec_out, except owner
7815 * and protection information. Name and type of spec_in are used as
7816 * defaults for spec_out. The third parameter specifies whether rmscopy()
7817 * should try to propagate timestamps from the input file to the output file.
7818 * If it is less than 0, no timestamps are preserved. If it is 0, then
7819 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
7820 * propagated to the output file at creation iff the output file specification
7821 * did not contain an explicit name or type, and the revision date is always
7822 * updated at the end of the copy operation. If it is greater than 0, then
7823 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
7824 * other than the revision date should be propagated, and bit 1 indicates
7825 * that the revision date should be propagated.
7827 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
7829 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
7830 * Incorporates, with permission, some code from EZCOPY by Tim Adye
7831 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
7832 * as part of the Perl standard distribution under the terms of the
7833 * GNU General Public License or the Perl Artistic License. Copies
7834 * of each may be found in the Perl standard distribution.
7836 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
7838 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
7840 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
7841 rsa[NAM$C_MAXRSS], ubf[32256];
7842 unsigned long int i, sts, sts2;
7843 struct FAB fab_in, fab_out;
7844 struct RAB rab_in, rab_out;
7846 struct XABDAT xabdat;
7847 struct XABFHC xabfhc;
7848 struct XABRDT xabrdt;
7849 struct XABSUM xabsum;
7851 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
7852 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
7853 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7857 fab_in = cc$rms_fab;
7858 fab_in.fab$l_fna = vmsin;
7859 fab_in.fab$b_fns = strlen(vmsin);
7860 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
7861 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
7862 fab_in.fab$l_fop = FAB$M_SQO;
7863 fab_in.fab$l_nam = &nam;
7864 fab_in.fab$l_xab = (void *) &xabdat;
7867 nam.nam$l_rsa = rsa;
7868 nam.nam$b_rss = sizeof(rsa);
7869 nam.nam$l_esa = esa;
7870 nam.nam$b_ess = sizeof (esa);
7871 nam.nam$b_esl = nam.nam$b_rsl = 0;
7872 #ifdef NAM$M_NO_SHORT_UPCASE
7873 if (decc_efs_case_preserve)
7874 nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
7877 xabdat = cc$rms_xabdat; /* To get creation date */
7878 xabdat.xab$l_nxt = (void *) &xabfhc;
7880 xabfhc = cc$rms_xabfhc; /* To get record length */
7881 xabfhc.xab$l_nxt = (void *) &xabsum;
7883 xabsum = cc$rms_xabsum; /* To get key and area information */
7885 if (!((sts = sys$open(&fab_in)) & 1)) {
7886 set_vaxc_errno(sts);
7888 case RMS$_FNF: case RMS$_DNF:
7889 set_errno(ENOENT); break;
7891 set_errno(ENOTDIR); break;
7893 set_errno(ENODEV); break;
7895 set_errno(EINVAL); break;
7897 set_errno(EACCES); break;
7905 fab_out.fab$w_ifi = 0;
7906 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
7907 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
7908 fab_out.fab$l_fop = FAB$M_SQO;
7909 fab_out.fab$l_fna = vmsout;
7910 fab_out.fab$b_fns = strlen(vmsout);
7911 fab_out.fab$l_dna = nam.nam$l_name;
7912 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
7914 if (preserve_dates == 0) { /* Act like DCL COPY */
7915 nam.nam$b_nop |= NAM$M_SYNCHK;
7916 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
7917 if (!((sts = sys$parse(&fab_out)) & 1)) {
7918 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
7919 set_vaxc_errno(sts);
7922 fab_out.fab$l_xab = (void *) &xabdat;
7923 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
7925 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
7926 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
7927 preserve_dates =0; /* bitmask from this point forward */
7929 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
7930 if (!((sts = sys$create(&fab_out)) & 1)) {
7931 set_vaxc_errno(sts);
7934 set_errno(ENOENT); break;
7936 set_errno(ENOTDIR); break;
7938 set_errno(ENODEV); break;
7940 set_errno(EINVAL); break;
7942 set_errno(EACCES); break;
7948 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
7949 if (preserve_dates & 2) {
7950 /* sys$close() will process xabrdt, not xabdat */
7951 xabrdt = cc$rms_xabrdt;
7953 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
7955 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
7956 * is unsigned long[2], while DECC & VAXC use a struct */
7957 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
7959 fab_out.fab$l_xab = (void *) &xabrdt;
7962 rab_in = cc$rms_rab;
7963 rab_in.rab$l_fab = &fab_in;
7964 rab_in.rab$l_rop = RAB$M_BIO;
7965 rab_in.rab$l_ubf = ubf;
7966 rab_in.rab$w_usz = sizeof ubf;
7967 if (!((sts = sys$connect(&rab_in)) & 1)) {
7968 sys$close(&fab_in); sys$close(&fab_out);
7969 set_errno(EVMSERR); set_vaxc_errno(sts);
7973 rab_out = cc$rms_rab;
7974 rab_out.rab$l_fab = &fab_out;
7975 rab_out.rab$l_rbf = ubf;
7976 if (!((sts = sys$connect(&rab_out)) & 1)) {
7977 sys$close(&fab_in); sys$close(&fab_out);
7978 set_errno(EVMSERR); set_vaxc_errno(sts);
7982 while ((sts = sys$read(&rab_in))) { /* always true */
7983 if (sts == RMS$_EOF) break;
7984 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
7985 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
7986 sys$close(&fab_in); sys$close(&fab_out);
7987 set_errno(EVMSERR); set_vaxc_errno(sts);
7992 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
7993 sys$close(&fab_in); sys$close(&fab_out);
7994 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
7996 set_errno(EVMSERR); set_vaxc_errno(sts);
8002 } /* end of rmscopy() */
8006 /*** The following glue provides 'hooks' to make some of the routines
8007 * from this file available from Perl. These routines are sufficiently
8008 * basic, and are required sufficiently early in the build process,
8009 * that's it's nice to have them available to miniperl as well as the
8010 * full Perl, so they're set up here instead of in an extension. The
8011 * Perl code which handles importation of these names into a given
8012 * package lives in [.VMS]Filespec.pm in @INC.
8016 rmsexpand_fromperl(pTHX_ CV *cv)
8019 char *fspec, *defspec = NULL, *rslt;
8022 if (!items || items > 2)
8023 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
8024 fspec = SvPV(ST(0),n_a);
8025 if (!fspec || !*fspec) XSRETURN_UNDEF;
8026 if (items == 2) defspec = SvPV(ST(1),n_a);
8028 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
8029 ST(0) = sv_newmortal();
8030 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
8035 vmsify_fromperl(pTHX_ CV *cv)
8041 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
8042 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
8043 ST(0) = sv_newmortal();
8044 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
8049 unixify_fromperl(pTHX_ CV *cv)
8055 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
8056 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
8057 ST(0) = sv_newmortal();
8058 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
8063 fileify_fromperl(pTHX_ CV *cv)
8069 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
8070 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
8071 ST(0) = sv_newmortal();
8072 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
8077 pathify_fromperl(pTHX_ CV *cv)
8083 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
8084 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
8085 ST(0) = sv_newmortal();
8086 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
8091 vmspath_fromperl(pTHX_ CV *cv)
8097 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
8098 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
8099 ST(0) = sv_newmortal();
8100 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
8105 unixpath_fromperl(pTHX_ CV *cv)
8111 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
8112 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
8113 ST(0) = sv_newmortal();
8114 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
8119 candelete_fromperl(pTHX_ CV *cv)
8122 char fspec[NAM$C_MAXRSS+1], *fsp;
8127 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
8129 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
8130 if (SvTYPE(mysv) == SVt_PVGV) {
8131 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
8132 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8139 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
8140 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8146 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
8151 rmscopy_fromperl(pTHX_ CV *cv)
8154 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
8156 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
8157 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8158 unsigned long int sts;
8163 if (items < 2 || items > 3)
8164 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
8166 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
8167 if (SvTYPE(mysv) == SVt_PVGV) {
8168 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
8169 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8176 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
8177 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8182 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
8183 if (SvTYPE(mysv) == SVt_PVGV) {
8184 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
8185 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8192 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
8193 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8198 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
8200 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
8206 mod2fname(pTHX_ CV *cv)
8209 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
8210 workbuff[NAM$C_MAXRSS*1 + 1];
8211 int total_namelen = 3, counter, num_entries;
8212 /* ODS-5 ups this, but we want to be consistent, so... */
8213 int max_name_len = 39;
8214 AV *in_array = (AV *)SvRV(ST(0));
8216 num_entries = av_len(in_array);
8218 /* All the names start with PL_. */
8219 strcpy(ultimate_name, "PL_");
8221 /* Clean up our working buffer */
8222 Zero(work_name, sizeof(work_name), char);
8224 /* Run through the entries and build up a working name */
8225 for(counter = 0; counter <= num_entries; counter++) {
8226 /* If it's not the first name then tack on a __ */
8228 strcat(work_name, "__");
8230 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
8234 /* Check to see if we actually have to bother...*/
8235 if (strlen(work_name) + 3 <= max_name_len) {
8236 strcat(ultimate_name, work_name);
8238 /* It's too darned big, so we need to go strip. We use the same */
8239 /* algorithm as xsubpp does. First, strip out doubled __ */
8240 char *source, *dest, last;
8243 for (source = work_name; *source; source++) {
8244 if (last == *source && last == '_') {
8250 /* Go put it back */
8251 strcpy(work_name, workbuff);
8252 /* Is it still too big? */
8253 if (strlen(work_name) + 3 > max_name_len) {
8254 /* Strip duplicate letters */
8257 for (source = work_name; *source; source++) {
8258 if (last == toupper(*source)) {
8262 last = toupper(*source);
8264 strcpy(work_name, workbuff);
8267 /* Is it *still* too big? */
8268 if (strlen(work_name) + 3 > max_name_len) {
8269 /* Too bad, we truncate */
8270 work_name[max_name_len - 2] = 0;
8272 strcat(ultimate_name, work_name);
8275 /* Okay, return it */
8276 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
8281 hushexit_fromperl(pTHX_ CV *cv)
8286 VMSISH_HUSHED = SvTRUE(ST(0));
8288 ST(0) = boolSV(VMSISH_HUSHED);
8293 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
8294 struct interp_intern *dst)
8296 memcpy(dst,src,sizeof(struct interp_intern));
8300 Perl_sys_intern_clear(pTHX)
8305 Perl_sys_intern_init(pTHX)
8307 unsigned int ix = RAND_MAX;
8313 MY_INV_RAND_MAX = 1./x;
8317 init_os_extras(void)
8320 char* file = __FILE__;
8321 char temp_buff[512];
8322 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
8323 no_translate_barewords = TRUE;
8325 no_translate_barewords = FALSE;
8328 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
8329 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
8330 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
8331 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
8332 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
8333 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
8334 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
8335 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
8336 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
8337 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
8338 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
8340 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
8343 #if __CRTL_VER >= 70301000 && !defined(__VAX)
8344 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
8348 store_pipelocs(aTHX); /* will redo any earlier attempts */
8355 #if __CRTL_VER == 80200000
8356 /* This missed getting in to the DECC SDK for 8.2 */
8357 char *realpath(const char *file_name, char * resolved_name, ...);
8360 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
8361 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
8362 * The perl fallback routine to provide realpath() is not as efficient
8366 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
8368 return realpath(filespec, outbuf);
8372 /* External entry points */
8373 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
8374 { return do_vms_realpath(filespec, outbuf); }
8376 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
8381 #if __CRTL_VER >= 70301000 && !defined(__VAX)
8384 /*{{{int do_vms_case_tolerant(void)*/
8385 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
8386 * controlled by a process setting.
8388 int do_vms_case_tolerant(void)
8390 return vms_process_case_tolerant;
8393 /* External entry points */
8394 int Perl_vms_case_tolerant(void)
8395 { return do_vms_case_tolerant(); }
8397 int Perl_vms_case_tolerant(void)
8398 { return vms_process_case_tolerant; }
8402 /* Start of DECC RTL Feature handling */
8404 static int sys_trnlnm
8405 (const char * logname,
8409 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
8410 const unsigned long attr = LNM$M_CASE_BLIND;
8411 struct dsc$descriptor_s name_dsc;
8413 unsigned short result;
8414 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
8417 name_dsc.dsc$w_length = strlen(logname);
8418 name_dsc.dsc$a_pointer = (char *)logname;
8419 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
8420 name_dsc.dsc$b_class = DSC$K_CLASS_S;
8422 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
8424 if ($VMS_STATUS_SUCCESS(status)) {
8426 /* Null terminate and return the string */
8427 /*--------------------------------------*/
8434 static int sys_crelnm
8435 (const char * logname,
8439 const char * proc_table = "LNM$PROCESS_TABLE";
8440 struct dsc$descriptor_s proc_table_dsc;
8441 struct dsc$descriptor_s logname_dsc;
8442 struct itmlst_3 item_list[2];
8444 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
8445 proc_table_dsc.dsc$w_length = strlen(proc_table);
8446 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
8447 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
8449 logname_dsc.dsc$a_pointer = (char *) logname;
8450 logname_dsc.dsc$w_length = strlen(logname);
8451 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
8452 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
8454 item_list[0].buflen = strlen(value);
8455 item_list[0].itmcode = LNM$_STRING;
8456 item_list[0].bufadr = (char *)value;
8457 item_list[0].retlen = NULL;
8459 item_list[1].buflen = 0;
8460 item_list[1].itmcode = 0;
8462 ret_val = sys$crelnm
8464 (const struct dsc$descriptor_s *)&proc_table_dsc,
8465 (const struct dsc$descriptor_s *)&logname_dsc,
8467 (const struct item_list_3 *) item_list);
8473 /* C RTL Feature settings */
8475 static int set_features
8476 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
8477 int (* cli_routine)(void), /* Not documented */
8478 void *image_info) /* Not documented */
8485 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
8486 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
8487 unsigned long case_perm;
8488 unsigned long case_image;
8490 #if __CRTL_VER >= 70300000 && !defined(__VAX)
8491 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
8493 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
8494 if (decc_disable_to_vms_logname_translation < 0)
8495 decc_disable_to_vms_logname_translation = 0;
8498 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
8500 decc_efs_case_preserve = decc$feature_get_value(s, 1);
8501 if (decc_efs_case_preserve < 0)
8502 decc_efs_case_preserve = 0;
8505 s = decc$feature_get_index("DECC$EFS_CHARSET");
8507 decc_efs_charset = decc$feature_get_value(s, 1);
8508 if (decc_efs_charset < 0)
8509 decc_efs_charset = 0;
8512 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
8514 decc_filename_unix_report = decc$feature_get_value(s, 1);
8515 if (decc_filename_unix_report > 0)
8516 decc_filename_unix_report = 1;
8518 decc_filename_unix_report = 0;
8521 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
8523 decc_filename_unix_only = decc$feature_get_value(s, 1);
8524 if (decc_filename_unix_only > 0) {
8525 decc_filename_unix_only = 1;
8528 decc_filename_unix_only = 0;
8532 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
8534 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
8535 if (decc_filename_unix_no_version < 0)
8536 decc_filename_unix_no_version = 0;
8539 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
8541 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
8542 if (decc_readdir_dropdotnotype < 0)
8543 decc_readdir_dropdotnotype = 0;
8546 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
8547 if ($VMS_STATUS_SUCCESS(status)) {
8548 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
8550 dflt = decc$feature_get_value(s, 4);
8552 decc_disable_posix_root = decc$feature_get_value(s, 1);
8553 if (decc_disable_posix_root <= 0) {
8554 decc$feature_set_value(s, 1, 1);
8555 decc_disable_posix_root = 1;
8559 /* Traditionally Perl assumes this is off */
8560 decc_disable_posix_root = 1;
8561 decc$feature_set_value(s, 1, 1);
8566 #if __CRTL_VER >= 80200000
8567 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
8569 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
8570 if (decc_posix_compliant_pathnames < 0)
8571 decc_posix_compliant_pathnames = 0;
8572 if (decc_posix_compliant_pathnames > 4)
8573 decc_posix_compliant_pathnames = 0;
8579 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
8580 if ($VMS_STATUS_SUCCESS(status)) {
8581 val_str[0] = _toupper(val_str[0]);
8582 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8583 decc_disable_to_vms_logname_translation = 1;
8588 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
8589 if ($VMS_STATUS_SUCCESS(status)) {
8590 val_str[0] = _toupper(val_str[0]);
8591 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8592 decc_efs_case_preserve = 1;
8597 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
8598 if ($VMS_STATUS_SUCCESS(status)) {
8599 val_str[0] = _toupper(val_str[0]);
8600 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8601 decc_filename_unix_report = 1;
8604 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
8605 if ($VMS_STATUS_SUCCESS(status)) {
8606 val_str[0] = _toupper(val_str[0]);
8607 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8608 decc_filename_unix_only = 1;
8609 decc_filename_unix_report = 1;
8612 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
8613 if ($VMS_STATUS_SUCCESS(status)) {
8614 val_str[0] = _toupper(val_str[0]);
8615 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8616 decc_filename_unix_no_version = 1;
8619 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
8620 if ($VMS_STATUS_SUCCESS(status)) {
8621 val_str[0] = _toupper(val_str[0]);
8622 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
8623 decc_readdir_dropdotnotype = 1;
8630 /* Report true case tolerance */
8631 /*----------------------------*/
8632 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
8633 if (!$VMS_STATUS_SUCCESS(status))
8634 case_perm = PPROP$K_CASE_BLIND;
8635 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
8636 if (!$VMS_STATUS_SUCCESS(status))
8637 case_image = PPROP$K_CASE_BLIND;
8638 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
8639 (case_image == PPROP$K_CASE_SENSITIVE))
8640 vms_process_case_tolerant = 0;
8645 /* CRTL can be initialized past this point, but not before. */
8646 /* DECC$CRTL_INIT(); */
8652 /* DECC dependent attributes */
8653 #if __DECC_VER < 60560002
8655 #define not_executable
8657 #define relative ,rel
8658 #define not_executable ,noexe
8661 #pragma extern_model save
8662 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
8664 const __align (LONGWORD) int spare[8] = {0};
8665 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
8668 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
8669 nowrt,noshr relative not_executable
8671 const long vms_cc_features = (const long)set_features;
8674 ** Force a reference to LIB$INITIALIZE to ensure it
8675 ** exists in the image.
8677 int lib$initialize(void);
8679 #pragma extern_model strict_refdef
8681 int lib_init_ref = (int) lib$initialize;
8684 #pragma extern_model restore