3 * VMS-specific routines for perl5
6 * August 2005 Convert VMS status code to UNIX status codes
7 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
8 * and Perl_cando by Craig Berry
9 * 29-Aug-2000 Charles Lane's piping improvements rolled in
10 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
19 #include <climsgdef.h>
29 #include <libclidef.h>
31 #include <lib$routines.h>
34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
44 #include <str$routines.h>
51 /* Set the maximum filespec size here as it is larger for EFS file
53 * Not fully implemented at this time because the larger size
54 * will likely impact the stack local storage requirements of
55 * threaded code, and probably cause hard to diagnose failures.
56 * To implement the larger sizes, all places where filename
57 * storage is put on the stack need to be changed to use
58 * New()/SafeFree() instead.
63 #define VMS_MAXRSS (NAML$C_MAXRSS+1)
64 #ifndef VMS_LONGNAME_SUPPORT
65 #define VMS_LONGNAME_SUPPORT 1
66 #endif /* VMS_LONGNAME_SUPPORT */
67 #endif /* NAML$C_MAXRSS */
68 #endif /* VMS_MAXRSS */
71 /* temporary hack until support is complete */
72 #ifdef VMS_LONGNAME_SUPPORT
73 #undef VMS_LONGNAME_SUPPORT
76 /* end of temporary hack until support is complete */
79 #define VMS_MAXRSS (NAM$C_MAXRSS + 1)
82 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
83 int decc$feature_get_index(const char *name);
84 char* decc$feature_get_name(int index);
85 int decc$feature_get_value(int index, int mode);
86 int decc$feature_set_value(int index, int mode, int value);
91 #if __CRTL_VER >= 70300000 && !defined(__VAX)
93 static int set_feature_default(const char *name, int value)
98 index = decc$feature_get_index(name);
100 status = decc$feature_set_value(index, 1, value);
101 if (index == -1 || (status == -1)) {
105 status = decc$feature_get_value(index, 1);
106 if (status != value) {
114 /* Older versions of ssdef.h don't have these */
115 #ifndef SS$_INVFILFOROP
116 # define SS$_INVFILFOROP 3930
118 #ifndef SS$_NOSUCHOBJECT
119 # define SS$_NOSUCHOBJECT 2696
122 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
123 #define PERLIO_NOT_STDIO 0
125 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
126 * code below needs to get to the underlying CRTL routines. */
127 #define DONT_MASK_RTL_CALLS
131 /* Anticipating future expansion in lexical warnings . . . */
132 #ifndef WARN_INTERNAL
133 # define WARN_INTERNAL WARN_MISC
136 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
137 # define RTL_USES_UTC 1
141 /* gcc's header files don't #define direct access macros
142 * corresponding to VAXC's variant structs */
144 # define uic$v_format uic$r_uic_form.uic$v_format
145 # define uic$v_group uic$r_uic_form.uic$v_group
146 # define uic$v_member uic$r_uic_form.uic$v_member
147 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
148 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
149 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
150 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
153 #if defined(NEED_AN_H_ERRNO)
158 #pragma message disable pragma
159 #pragma member_alignment save
160 #pragma nomember_alignment longword
162 #pragma message disable misalgndmem
165 unsigned short int buflen;
166 unsigned short int itmcode;
168 unsigned short int *retlen;
171 #pragma message restore
172 #pragma member_alignment restore
175 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
176 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
177 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
178 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
179 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
180 #define do_vms_realpath(a,b) mp_do_vms_realpath(aTHX_ a,b)
181 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
182 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
183 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
184 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
185 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
187 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
188 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
189 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
190 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
192 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
193 #define PERL_LNM_MAX_ALLOWED_INDEX 127
195 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
196 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
199 #define PERL_LNM_MAX_ITER 10
201 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
202 #if __CRTL_VER >= 70302000 && !defined(__VAX)
203 #define MAX_DCL_SYMBOL (8192)
204 #define MAX_DCL_LINE_LENGTH (4096 - 4)
206 #define MAX_DCL_SYMBOL (1024)
207 #define MAX_DCL_LINE_LENGTH (1024 - 4)
210 static char *__mystrtolower(char *str)
212 if (str) for (; *str; ++str) *str= tolower(*str);
216 static struct dsc$descriptor_s fildevdsc =
217 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
218 static struct dsc$descriptor_s crtlenvdsc =
219 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
220 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
221 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
222 static struct dsc$descriptor_s **env_tables = defenv;
223 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
225 /* True if we shouldn't treat barewords as logicals during directory */
227 static int no_translate_barewords;
230 static int tz_updated = 1;
233 /* DECC Features that may need to affect how Perl interprets
234 * displays filename information
236 static int decc_disable_to_vms_logname_translation = 1;
237 static int decc_disable_posix_root = 1;
238 int decc_efs_case_preserve = 0;
239 static int decc_efs_charset = 0;
240 static int decc_filename_unix_no_version = 0;
241 static int decc_filename_unix_only = 0;
242 int decc_filename_unix_report = 0;
243 int decc_posix_compliant_pathnames = 0;
244 int decc_readdir_dropdotnotype = 0;
245 static int vms_process_case_tolerant = 1;
247 /* bug workarounds if needed */
248 int decc_bug_readdir_efs1 = 0;
249 int decc_bug_devnull = 0;
250 int decc_bug_fgetname = 0;
251 int decc_dir_barename = 0;
253 /* Is this a UNIX file specification?
254 * No longer a simple check with EFS file specs
255 * For now, not a full check, but need to
256 * handle POSIX ^UP^ specifications
257 * Fixing to handle ^/ cases would require
258 * changes to many other conversion routines.
261 static is_unix_filespec(const char *path)
267 if (strncmp(path,"\"^UP^",5) != 0) {
268 pch1 = strchr(path, '/');
273 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
274 if (decc_filename_unix_report || decc_filename_unix_only) {
275 if (strcmp(path,".") == 0)
285 * Routine to retrieve the maximum equivalence index for an input
286 * logical name. Some calls to this routine have no knowledge if
287 * the variable is a logical or not. So on error we return a max
290 /*{{{int my_maxidx(const char *lnm) */
292 my_maxidx(const char *lnm)
296 int attr = LNM$M_CASE_BLIND;
297 struct dsc$descriptor lnmdsc;
298 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
301 lnmdsc.dsc$w_length = strlen(lnm);
302 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
303 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
304 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
306 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
307 if ((status & 1) == 0)
314 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
316 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
317 struct dsc$descriptor_s **tabvec, unsigned long int flags)
320 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
321 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
322 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
324 unsigned char acmode;
325 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
326 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
327 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
328 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
330 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
331 #if defined(PERL_IMPLICIT_CONTEXT)
334 aTHX = PERL_GET_INTERP;
340 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
341 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
343 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
344 *cp2 = _toupper(*cp1);
345 if (cp1 - lnm > LNM$C_NAMLENGTH) {
346 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
350 lnmdsc.dsc$w_length = cp1 - lnm;
351 lnmdsc.dsc$a_pointer = uplnm;
352 uplnm[lnmdsc.dsc$w_length] = '\0';
353 secure = flags & PERL__TRNENV_SECURE;
354 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
355 if (!tabvec || !*tabvec) tabvec = env_tables;
357 for (curtab = 0; tabvec[curtab]; curtab++) {
358 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
359 if (!ivenv && !secure) {
364 Perl_warn(aTHX_ "Can't read CRTL environ\n");
367 retsts = SS$_NOLOGNAM;
368 for (i = 0; environ[i]; i++) {
369 if ((eq = strchr(environ[i],'=')) &&
370 lnmdsc.dsc$w_length == (eq - environ[i]) &&
371 !strncmp(environ[i],uplnm,eq - environ[i])) {
373 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
374 if (!eqvlen) continue;
379 if (retsts != SS$_NOLOGNAM) break;
382 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
383 !str$case_blind_compare(&tmpdsc,&clisym)) {
384 if (!ivsym && !secure) {
385 unsigned short int deflen = LNM$C_NAMLENGTH;
386 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
387 /* dynamic dsc to accomodate possible long value */
388 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
389 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
391 if (eqvlen > MAX_DCL_SYMBOL) {
392 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
393 eqvlen = MAX_DCL_SYMBOL;
394 /* Special hack--we might be called before the interpreter's */
395 /* fully initialized, in which case either thr or PL_curcop */
396 /* might be bogus. We have to check, since ckWARN needs them */
397 /* both to be valid if running threaded */
398 if (ckWARN(WARN_MISC)) {
399 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
402 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
404 _ckvmssts(lib$sfree1_dd(&eqvdsc));
405 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
406 if (retsts == LIB$_NOSUCHSYM) continue;
411 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
412 midx = my_maxidx(lnm);
413 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
414 lnmlst[1].bufadr = cp2;
416 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
417 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
418 if (retsts == SS$_NOLOGNAM) break;
419 /* PPFs have a prefix */
422 *((int *)uplnm) == *((int *)"SYS$") &&
424 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
425 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
426 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
427 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
428 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
429 memmove(eqv,eqv+4,eqvlen-4);
435 if ((retsts == SS$_IVLOGNAM) ||
436 (retsts == SS$_NOLOGNAM)) { continue; }
439 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
440 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
441 if (retsts == SS$_NOLOGNAM) continue;
444 eqvlen = strlen(eqv);
448 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
449 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
450 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
451 retsts == SS$_NOLOGNAM) {
452 set_errno(EINVAL); set_vaxc_errno(retsts);
454 else _ckvmssts(retsts);
456 } /* end of vmstrnenv */
459 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
460 /* Define as a function so we can access statics. */
461 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
463 return vmstrnenv(lnm,eqv,idx,fildev,
464 #ifdef SECURE_INTERNAL_GETENV
465 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
474 * Note: Uses Perl temp to store result so char * can be returned to
475 * caller; this pointer will be invalidated at next Perl statement
477 * We define this as a function rather than a macro in terms of my_getenv_len()
478 * so that it'll work when PL_curinterp is undefined (and we therefore can't
481 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
483 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
486 static char *__my_getenv_eqv = NULL;
487 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
488 unsigned long int idx = 0;
489 int trnsuccess, success, secure, saverr, savvmserr;
493 midx = my_maxidx(lnm) + 1;
495 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
496 /* Set up a temporary buffer for the return value; Perl will
497 * clean it up at the next statement transition */
498 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
499 if (!tmpsv) return NULL;
503 /* Assume no interpreter ==> single thread */
504 if (__my_getenv_eqv != NULL) {
505 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
508 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
510 eqv = __my_getenv_eqv;
513 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
514 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
516 getcwd(eqv,LNM$C_NAMLENGTH);
520 /* Get rid of "000000/ in rooted filespecs */
523 zeros = strstr(eqv, "/000000/");
526 mlen = len - (zeros - eqv) - 7;
527 memmove(zeros, &zeros[7], mlen);
535 /* Impose security constraints only if tainting */
537 /* Impose security constraints only if tainting */
538 secure = PL_curinterp ? PL_tainting : will_taint;
539 saverr = errno; savvmserr = vaxc$errno;
546 #ifdef SECURE_INTERNAL_GETENV
547 secure ? PERL__TRNENV_SECURE : 0
553 /* For the getenv interface we combine all the equivalence names
554 * of a search list logical into one value to acquire a maximum
555 * value length of 255*128 (assuming %ENV is using logicals).
557 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
559 /* If the name contains a semicolon-delimited index, parse it
560 * off and make sure we only retrieve the equivalence name for
562 if ((cp2 = strchr(lnm,';')) != NULL) {
564 uplnm[cp2-lnm] = '\0';
565 idx = strtoul(cp2+1,NULL,0);
567 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
570 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
572 /* Discard NOLOGNAM on internal calls since we're often looking
573 * for an optional name, and this "error" often shows up as the
574 * (bogus) exit status for a die() call later on. */
575 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
576 return success ? eqv : Nullch;
579 } /* end of my_getenv() */
583 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
585 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
589 unsigned long idx = 0;
591 static char *__my_getenv_len_eqv = NULL;
592 int secure, saverr, savvmserr;
595 midx = my_maxidx(lnm) + 1;
597 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
598 /* Set up a temporary buffer for the return value; Perl will
599 * clean it up at the next statement transition */
600 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
601 if (!tmpsv) return NULL;
605 /* Assume no interpreter ==> single thread */
606 if (__my_getenv_len_eqv != NULL) {
607 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
610 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
612 buf = __my_getenv_len_eqv;
615 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
616 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
619 getcwd(buf,LNM$C_NAMLENGTH);
622 /* Get rid of "000000/ in rooted filespecs */
624 zeros = strstr(buf, "/000000/");
627 mlen = *len - (zeros - buf) - 7;
628 memmove(zeros, &zeros[7], mlen);
637 /* Impose security constraints only if tainting */
638 secure = PL_curinterp ? PL_tainting : will_taint;
639 saverr = errno; savvmserr = vaxc$errno;
646 #ifdef SECURE_INTERNAL_GETENV
647 secure ? PERL__TRNENV_SECURE : 0
653 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
655 if ((cp2 = strchr(lnm,';')) != NULL) {
658 idx = strtoul(cp2+1,NULL,0);
660 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
663 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
665 /* Get rid of "000000/ in rooted filespecs */
668 zeros = strstr(buf, "/000000/");
671 mlen = *len - (zeros - buf) - 7;
672 memmove(zeros, &zeros[7], mlen);
678 /* Discard NOLOGNAM on internal calls since we're often looking
679 * for an optional name, and this "error" often shows up as the
680 * (bogus) exit status for a die() call later on. */
681 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
682 return *len ? buf : Nullch;
685 } /* end of my_getenv_len() */
688 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
690 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
692 /*{{{ void prime_env_iter() */
695 /* Fill the %ENV associative array with all logical names we can
696 * find, in preparation for iterating over it.
699 static int primed = 0;
700 HV *seenhv = NULL, *envhv;
702 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
703 unsigned short int chan;
704 #ifndef CLI$M_TRUSTED
705 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
707 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
708 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
710 bool have_sym = FALSE, have_lnm = FALSE;
711 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
712 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
713 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
714 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
715 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
716 #if defined(PERL_IMPLICIT_CONTEXT)
719 #if defined(USE_ITHREADS)
720 static perl_mutex primenv_mutex;
721 MUTEX_INIT(&primenv_mutex);
724 #if defined(PERL_IMPLICIT_CONTEXT)
725 /* We jump through these hoops because we can be called at */
726 /* platform-specific initialization time, which is before anything is */
727 /* set up--we can't even do a plain dTHX since that relies on the */
728 /* interpreter structure to be initialized */
730 aTHX = PERL_GET_INTERP;
736 if (primed || !PL_envgv) return;
737 MUTEX_LOCK(&primenv_mutex);
738 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
739 envhv = GvHVn(PL_envgv);
740 /* Perform a dummy fetch as an lval to insure that the hash table is
741 * set up. Otherwise, the hv_store() will turn into a nullop. */
742 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
744 for (i = 0; env_tables[i]; i++) {
745 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
746 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
747 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
749 if (have_sym || have_lnm) {
750 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
751 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
752 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
753 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
756 for (i--; i >= 0; i--) {
757 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
760 for (j = 0; environ[j]; j++) {
761 if (!(start = strchr(environ[j],'='))) {
762 if (ckWARN(WARN_INTERNAL))
763 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
767 sv = newSVpv(start,0);
769 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
774 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
775 !str$case_blind_compare(&tmpdsc,&clisym)) {
776 strcpy(cmd,"Show Symbol/Global *");
777 cmddsc.dsc$w_length = 20;
778 if (env_tables[i]->dsc$w_length == 12 &&
779 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
780 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
781 flags = defflags | CLI$M_NOLOGNAM;
784 strcpy(cmd,"Show Logical *");
785 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
786 strcat(cmd," /Table=");
787 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
788 cmddsc.dsc$w_length = strlen(cmd);
790 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
791 flags = defflags | CLI$M_NOCLISYM;
794 /* Create a new subprocess to execute each command, to exclude the
795 * remote possibility that someone could subvert a mbx or file used
796 * to write multiple commands to a single subprocess.
799 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
800 0,&riseandshine,0,0,&clidsc,&clitabdsc);
801 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
802 defflags &= ~CLI$M_TRUSTED;
803 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
805 if (!buf) Newx(buf,mbxbufsiz + 1,char);
806 if (seenhv) SvREFCNT_dec(seenhv);
809 char *cp1, *cp2, *key;
810 unsigned long int sts, iosb[2], retlen, keylen;
813 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
814 if (sts & 1) sts = iosb[0] & 0xffff;
815 if (sts == SS$_ENDOFFILE) {
817 while (substs == 0) { sys$hiber(); wakect++;}
818 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
823 retlen = iosb[0] >> 16;
824 if (!retlen) continue; /* blank line */
826 if (iosb[1] != subpid) {
828 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
832 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
833 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
835 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
836 if (*cp1 == '(' || /* Logical name table name */
837 *cp1 == '=' /* Next eqv of searchlist */) continue;
838 if (*cp1 == '"') cp1++;
839 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
840 key = cp1; keylen = cp2 - cp1;
841 if (keylen && hv_exists(seenhv,key,keylen)) continue;
842 while (*cp2 && *cp2 != '=') cp2++;
843 while (*cp2 && *cp2 == '=') cp2++;
844 while (*cp2 && *cp2 == ' ') cp2++;
845 if (*cp2 == '"') { /* String translation; may embed "" */
846 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
847 cp2++; cp1--; /* Skip "" surrounding translation */
849 else { /* Numeric translation */
850 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
851 cp1--; /* stop on last non-space char */
853 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
854 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
857 PERL_HASH(hash,key,keylen);
859 if (cp1 == cp2 && *cp2 == '.') {
860 /* A single dot usually means an unprintable character, such as a null
861 * to indicate a zero-length value. Get the actual value to make sure.
863 char lnm[LNM$C_NAMLENGTH+1];
864 char eqv[MAX_DCL_SYMBOL+1];
865 strncpy(lnm, key, keylen);
866 int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
867 sv = newSVpvn(eqv, strlen(eqv));
870 sv = newSVpvn(cp2,cp1 - cp2 + 1);
874 hv_store(envhv,key,keylen,sv,hash);
875 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
877 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
878 /* get the PPFs for this process, not the subprocess */
879 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
880 char eqv[LNM$C_NAMLENGTH+1];
882 for (i = 0; ppfs[i]; i++) {
883 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
884 sv = newSVpv(eqv,trnlen);
886 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
891 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
892 if (buf) Safefree(buf);
893 if (seenhv) SvREFCNT_dec(seenhv);
894 MUTEX_UNLOCK(&primenv_mutex);
897 } /* end of prime_env_iter */
901 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
902 /* Define or delete an element in the same "environment" as
903 * vmstrnenv(). If an element is to be deleted, it's removed from
904 * the first place it's found. If it's to be set, it's set in the
905 * place designated by the first element of the table vector.
906 * Like setenv() returns 0 for success, non-zero on error.
909 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
912 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
913 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
915 unsigned long int retsts, usermode = PSL$C_USER;
916 struct itmlst_3 *ile, *ilist;
917 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
918 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
919 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
920 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
921 $DESCRIPTOR(local,"_LOCAL");
924 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
928 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
929 *cp2 = _toupper(*cp1);
930 if (cp1 - lnm > LNM$C_NAMLENGTH) {
931 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
935 lnmdsc.dsc$w_length = cp1 - lnm;
936 if (!tabvec || !*tabvec) tabvec = env_tables;
938 if (!eqv) { /* we're deleting n element */
939 for (curtab = 0; tabvec[curtab]; curtab++) {
940 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
942 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
943 if ((cp1 = strchr(environ[i],'=')) &&
944 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
945 !strncmp(environ[i],lnm,cp1 - environ[i])) {
947 return setenv(lnm,"",1) ? vaxc$errno : 0;
950 ivenv = 1; retsts = SS$_NOLOGNAM;
952 if (ckWARN(WARN_INTERNAL))
953 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
954 ivenv = 1; retsts = SS$_NOSUCHPGM;
960 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
961 !str$case_blind_compare(&tmpdsc,&clisym)) {
962 unsigned int symtype;
963 if (tabvec[curtab]->dsc$w_length == 12 &&
964 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
965 !str$case_blind_compare(&tmpdsc,&local))
966 symtype = LIB$K_CLI_LOCAL_SYM;
967 else symtype = LIB$K_CLI_GLOBAL_SYM;
968 retsts = lib$delete_symbol(&lnmdsc,&symtype);
969 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
970 if (retsts == LIB$_NOSUCHSYM) continue;
974 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
975 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
976 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
977 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
978 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
982 else { /* we're defining a value */
983 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
985 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
987 if (ckWARN(WARN_INTERNAL))
988 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
989 retsts = SS$_NOSUCHPGM;
993 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
994 eqvdsc.dsc$w_length = strlen(eqv);
995 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
996 !str$case_blind_compare(&tmpdsc,&clisym)) {
997 unsigned int symtype;
998 if (tabvec[0]->dsc$w_length == 12 &&
999 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1000 !str$case_blind_compare(&tmpdsc,&local))
1001 symtype = LIB$K_CLI_LOCAL_SYM;
1002 else symtype = LIB$K_CLI_GLOBAL_SYM;
1003 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1006 if (!*eqv) eqvdsc.dsc$w_length = 1;
1007 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1009 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1010 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1011 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1012 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1013 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1014 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1017 Newx(ilist,nseg+1,struct itmlst_3);
1020 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1023 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1025 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1026 ile->itmcode = LNM$_STRING;
1028 if ((j+1) == nseg) {
1029 ile->buflen = strlen(c);
1030 /* in case we are truncating one that's too long */
1031 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1034 ile->buflen = LNM$C_NAMLENGTH;
1038 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1042 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1047 if (!(retsts & 1)) {
1049 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1050 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1051 set_errno(EVMSERR); break;
1052 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1053 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1054 set_errno(EINVAL); break;
1061 set_vaxc_errno(retsts);
1062 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1065 /* We reset error values on success because Perl does an hv_fetch()
1066 * before each hv_store(), and if the thing we're setting didn't
1067 * previously exist, we've got a leftover error message. (Of course,
1068 * this fails in the face of
1069 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1070 * in that the error reported in $! isn't spurious,
1071 * but it's right more often than not.)
1073 set_errno(0); set_vaxc_errno(retsts);
1077 } /* end of vmssetenv() */
1080 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1081 /* This has to be a function since there's a prototype for it in proto.h */
1083 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1086 int len = strlen(lnm);
1090 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1091 if (!strcmp(uplnm,"DEFAULT")) {
1092 if (eqv && *eqv) my_chdir(eqv);
1096 #ifndef RTL_USES_UTC
1097 if (len == 6 || len == 2) {
1100 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1102 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1103 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1107 (void) vmssetenv(lnm,eqv,NULL);
1111 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1113 * sets a user-mode logical in the process logical name table
1114 * used for redirection of sys$error
1117 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1119 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1120 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1121 unsigned long int iss, attr = LNM$M_CONFINE;
1122 unsigned char acmode = PSL$C_USER;
1123 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1125 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1126 d_name.dsc$w_length = strlen(name);
1128 lnmlst[0].buflen = strlen(eqv);
1129 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1131 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1132 if (!(iss&1)) lib$signal(iss);
1137 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1138 /* my_crypt - VMS password hashing
1139 * my_crypt() provides an interface compatible with the Unix crypt()
1140 * C library function, and uses sys$hash_password() to perform VMS
1141 * password hashing. The quadword hashed password value is returned
1142 * as a NUL-terminated 8 character string. my_crypt() does not change
1143 * the case of its string arguments; in order to match the behavior
1144 * of LOGINOUT et al., alphabetic characters in both arguments must
1145 * be upcased by the caller.
1147 * - fix me to call ACM services when available
1150 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1152 # ifndef UAI$C_PREFERRED_ALGORITHM
1153 # define UAI$C_PREFERRED_ALGORITHM 127
1155 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1156 unsigned short int salt = 0;
1157 unsigned long int sts;
1159 unsigned short int dsc$w_length;
1160 unsigned char dsc$b_type;
1161 unsigned char dsc$b_class;
1162 const char * dsc$a_pointer;
1163 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1164 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1165 struct itmlst_3 uailst[3] = {
1166 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1167 { sizeof salt, UAI$_SALT, &salt, 0},
1168 { 0, 0, NULL, NULL}};
1169 static char hash[9];
1171 usrdsc.dsc$w_length = strlen(usrname);
1172 usrdsc.dsc$a_pointer = usrname;
1173 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1175 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1179 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1184 set_vaxc_errno(sts);
1185 if (sts != RMS$_RNF) return NULL;
1188 txtdsc.dsc$w_length = strlen(textpasswd);
1189 txtdsc.dsc$a_pointer = textpasswd;
1190 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1191 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1194 return (char *) hash;
1196 } /* end of my_crypt() */
1200 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1201 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1202 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1204 /* fixup barenames that are directories for internal use.
1205 * There have been problems with the consistent handling of UNIX
1206 * style directory names when routines are presented with a name that
1207 * has no directory delimitors at all. So this routine will eventually
1210 static char * fixup_bare_dirnames(const char * name)
1212 if (decc_disable_to_vms_logname_translation) {
1219 * A little hack to get around a bug in some implemenation of remove()
1220 * that do not know how to delete a directory
1222 * Delete any file to which user has control access, regardless of whether
1223 * delete access is explicitly allowed.
1224 * Limitations: User must have write access to parent directory.
1225 * Does not block signals or ASTs; if interrupted in midstream
1226 * may leave file with an altered ACL.
1229 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1231 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1233 char *vmsname, *rspec;
1235 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1236 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1237 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1239 unsigned char myace$b_length;
1240 unsigned char myace$b_type;
1241 unsigned short int myace$w_flags;
1242 unsigned long int myace$l_access;
1243 unsigned long int myace$l_ident;
1244 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1245 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1246 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1248 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1249 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1250 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1251 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1252 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1253 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1255 /* Expand the input spec using RMS, since the CRTL remove() and
1256 * system services won't do this by themselves, so we may miss
1257 * a file "hiding" behind a logical name or search list. */
1258 Newx(vmsname, NAM$C_MAXRSS+1, char);
1259 if (do_tovmsspec(name,vmsname,0) == NULL) {
1264 if (decc_posix_compliant_pathnames) {
1265 /* In POSIX mode, we prefer to remove the UNIX name */
1267 remove_name = (char *)name;
1270 Newx(rspec, NAM$C_MAXRSS+1, char);
1271 if (do_rmsexpand(vmsname, rspec, 1, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1277 remove_name = rspec;
1280 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1282 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1283 Newx(remove_name, NAM$C_MAXRSS+1, char);
1284 do_pathify_dirspec(name, remove_name, 0);
1285 if (!rmdir(remove_name)) {
1287 Safefree(remove_name);
1289 return 0; /* Can we just get rid of it? */
1293 if (!rmdir(remove_name)) {
1295 return 0; /* Can we just get rid of it? */
1301 if (!remove(remove_name)) {
1303 return 0; /* Can we just get rid of it? */
1306 /* If not, can changing protections help? */
1307 if (vaxc$errno != RMS$_PRV) {
1312 /* No, so we get our own UIC to use as a rights identifier,
1313 * and the insert an ACE at the head of the ACL which allows us
1314 * to delete the file.
1316 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1317 fildsc.dsc$w_length = strlen(rspec);
1318 fildsc.dsc$a_pointer = rspec;
1320 newace.myace$l_ident = oldace.myace$l_ident;
1321 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1323 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1324 set_errno(ENOENT); break;
1326 set_errno(ENOTDIR); break;
1328 set_errno(ENODEV); break;
1329 case RMS$_SYN: case SS$_INVFILFOROP:
1330 set_errno(EINVAL); break;
1332 set_errno(EACCES); break;
1336 set_vaxc_errno(aclsts);
1340 /* Grab any existing ACEs with this identifier in case we fail */
1341 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1342 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1343 || fndsts == SS$_NOMOREACE ) {
1344 /* Add the new ACE . . . */
1345 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1348 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1350 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1351 Newx(remove_name, NAM$C_MAXRSS+1, char);
1352 do_pathify_dirspec(name, remove_name, 0);
1353 rmsts = rmdir(remove_name);
1354 Safefree(remove_name);
1357 rmsts = rmdir(remove_name);
1361 rmsts = remove(remove_name);
1363 /* We blew it - dir with files in it, no write priv for
1364 * parent directory, etc. Put things back the way they were. */
1365 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1368 addlst[0].bufadr = &oldace;
1369 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1376 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1377 /* We just deleted it, so of course it's not there. Some versions of
1378 * VMS seem to return success on the unlock operation anyhow (after all
1379 * the unlock is successful), but others don't.
1381 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1382 if (aclsts & 1) aclsts = fndsts;
1383 if (!(aclsts & 1)) {
1385 set_vaxc_errno(aclsts);
1393 } /* end of kill_file() */
1397 /*{{{int do_rmdir(char *name)*/
1399 Perl_do_rmdir(pTHX_ const char *name)
1401 char dirfile[NAM$C_MAXRSS+1];
1405 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1406 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1407 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1410 } /* end of do_rmdir */
1414 * Delete any file to which user has control access, regardless of whether
1415 * delete access is explicitly allowed.
1416 * Limitations: User must have write access to parent directory.
1417 * Does not block signals or ASTs; if interrupted in midstream
1418 * may leave file with an altered ACL.
1421 /*{{{int kill_file(char *name)*/
1423 Perl_kill_file(pTHX_ const char *name)
1425 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1426 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1427 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1428 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1430 unsigned char myace$b_length;
1431 unsigned char myace$b_type;
1432 unsigned short int myace$w_flags;
1433 unsigned long int myace$l_access;
1434 unsigned long int myace$l_ident;
1435 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1436 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1437 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1439 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1440 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1441 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1442 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1443 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1444 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1446 /* Expand the input spec using RMS, since the CRTL remove() and
1447 * system services won't do this by themselves, so we may miss
1448 * a file "hiding" behind a logical name or search list. */
1449 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1450 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1451 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1452 /* If not, can changing protections help? */
1453 if (vaxc$errno != RMS$_PRV) return -1;
1455 /* No, so we get our own UIC to use as a rights identifier,
1456 * and the insert an ACE at the head of the ACL which allows us
1457 * to delete the file.
1459 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1460 fildsc.dsc$w_length = strlen(rspec);
1461 fildsc.dsc$a_pointer = rspec;
1463 newace.myace$l_ident = oldace.myace$l_ident;
1464 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1466 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1467 set_errno(ENOENT); break;
1469 set_errno(ENOTDIR); break;
1471 set_errno(ENODEV); break;
1472 case RMS$_SYN: case SS$_INVFILFOROP:
1473 set_errno(EINVAL); break;
1475 set_errno(EACCES); break;
1479 set_vaxc_errno(aclsts);
1482 /* Grab any existing ACEs with this identifier in case we fail */
1483 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1484 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1485 || fndsts == SS$_NOMOREACE ) {
1486 /* Add the new ACE . . . */
1487 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1489 if ((rmsts = remove(name))) {
1490 /* We blew it - dir with files in it, no write priv for
1491 * parent directory, etc. Put things back the way they were. */
1492 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1495 addlst[0].bufadr = &oldace;
1496 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1503 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1504 /* We just deleted it, so of course it's not there. Some versions of
1505 * VMS seem to return success on the unlock operation anyhow (after all
1506 * the unlock is successful), but others don't.
1508 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1509 if (aclsts & 1) aclsts = fndsts;
1510 if (!(aclsts & 1)) {
1512 set_vaxc_errno(aclsts);
1518 } /* end of kill_file() */
1522 /*{{{int my_mkdir(char *,Mode_t)*/
1524 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1526 STRLEN dirlen = strlen(dir);
1528 /* zero length string sometimes gives ACCVIO */
1529 if (dirlen == 0) return -1;
1531 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1532 * null file name/type. However, it's commonplace under Unix,
1533 * so we'll allow it for a gain in portability.
1535 if (dir[dirlen-1] == '/') {
1536 char *newdir = savepvn(dir,dirlen-1);
1537 int ret = mkdir(newdir,mode);
1541 else return mkdir(dir,mode);
1542 } /* end of my_mkdir */
1545 /*{{{int my_chdir(char *)*/
1547 Perl_my_chdir(pTHX_ const char *dir)
1549 STRLEN dirlen = strlen(dir);
1551 /* zero length string sometimes gives ACCVIO */
1552 if (dirlen == 0) return -1;
1555 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1556 * This does not work if DECC$EFS_CHARSET is active. Hack it here
1557 * so that existing scripts do not need to be changed.
1560 while ((dirlen > 0) && (*dir1 == ' ')) {
1565 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1567 * null file name/type. However, it's commonplace under Unix,
1568 * so we'll allow it for a gain in portability.
1570 * - Preview- '/' will be valid soon on VMS
1572 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1573 char *newdir = savepvn(dir,dirlen-1);
1574 int ret = chdir(newdir);
1578 else return chdir(dir);
1579 } /* end of my_chdir */
1583 /*{{{FILE *my_tmpfile()*/
1590 if ((fp = tmpfile())) return fp;
1592 Newx(cp,L_tmpnam+24,char);
1593 if (decc_filename_unix_only == 0)
1594 strcpy(cp,"Sys$Scratch:");
1597 tmpnam(cp+strlen(cp));
1598 strcat(cp,".Perltmp");
1599 fp = fopen(cp,"w+","fop=dlt");
1606 #ifndef HOMEGROWN_POSIX_SIGNALS
1608 * The C RTL's sigaction fails to check for invalid signal numbers so we
1609 * help it out a bit. The docs are correct, but the actual routine doesn't
1610 * do what the docs say it will.
1612 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1614 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1615 struct sigaction* oact)
1617 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1618 SETERRNO(EINVAL, SS$_INVARG);
1621 return sigaction(sig, act, oact);
1626 #ifdef KILL_BY_SIGPRC
1627 #include <errnodef.h>
1629 /* We implement our own kill() using the undocumented system service
1630 sys$sigprc for one of two reasons:
1632 1.) If the kill() in an older CRTL uses sys$forcex, causing the
1633 target process to do a sys$exit, which usually can't be handled
1634 gracefully...certainly not by Perl and the %SIG{} mechanism.
1636 2.) If the kill() in the CRTL can't be called from a signal
1637 handler without disappearing into the ether, i.e., the signal
1638 it purportedly sends is never trapped. Still true as of VMS 7.3.
1640 sys$sigprc has the same parameters as sys$forcex, but throws an exception
1641 in the target process rather than calling sys$exit.
1643 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1644 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1645 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1646 with condition codes C$_SIG0+nsig*8, catching the exception on the
1647 target process and resignaling with appropriate arguments.
1649 But we don't have that VMS 7.0+ exception handler, so if you
1650 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1652 Also note that SIGTERM is listed in the docs as being "unimplemented",
1653 yet always seems to be signaled with a VMS condition code of 4 (and
1654 correctly handled for that code). So we hardwire it in.
1656 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1657 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1658 than signalling with an unrecognized (and unhandled by CRTL) code.
1661 #define _MY_SIG_MAX 17
1664 Perl_sig_to_vmscondition(int sig)
1666 static unsigned int sig_code[_MY_SIG_MAX+1] =
1669 SS$_HANGUP, /* 1 SIGHUP */
1670 SS$_CONTROLC, /* 2 SIGINT */
1671 SS$_CONTROLY, /* 3 SIGQUIT */
1672 SS$_RADRMOD, /* 4 SIGILL */
1673 SS$_BREAK, /* 5 SIGTRAP */
1674 SS$_OPCCUS, /* 6 SIGABRT */
1675 SS$_COMPAT, /* 7 SIGEMT */
1677 SS$_FLTOVF, /* 8 SIGFPE VAX */
1679 SS$_HPARITH, /* 8 SIGFPE AXP */
1681 SS$_ABORT, /* 9 SIGKILL */
1682 SS$_ACCVIO, /* 10 SIGBUS */
1683 SS$_ACCVIO, /* 11 SIGSEGV */
1684 SS$_BADPARAM, /* 12 SIGSYS */
1685 SS$_NOMBX, /* 13 SIGPIPE */
1686 SS$_ASTFLT, /* 14 SIGALRM */
1692 #if __VMS_VER >= 60200000
1693 static int initted = 0;
1696 sig_code[16] = C$_SIGUSR1;
1697 sig_code[17] = C$_SIGUSR2;
1701 if (sig < _SIG_MIN) return 0;
1702 if (sig > _MY_SIG_MAX) return 0;
1703 return sig_code[sig];
1707 Perl_my_kill(int pid, int sig)
1712 int sys$sigprc(unsigned int *pidadr,
1713 struct dsc$descriptor_s *prcname,
1716 /* sig 0 means validate the PID */
1717 /*------------------------------*/
1719 const unsigned long int jpicode = JPI$_PID;
1722 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
1723 if ($VMS_STATUS_SUCCESS(status))
1726 case SS$_NOSUCHNODE:
1727 case SS$_UNREACHABLE:
1741 code = Perl_sig_to_vmscondition(sig);
1744 SETERRNO(EINVAL, SS$_BADPARAM);
1748 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
1749 * signals are to be sent to multiple processes.
1750 * pid = 0 - all processes in group except ones that the system exempts
1751 * pid = -1 - all processes except ones that the system exempts
1752 * pid = -n - all processes in group (abs(n)) except ...
1753 * For now, just report as not supported.
1757 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
1761 iss = sys$sigprc((unsigned int *)&pid,0,code);
1762 if (iss&1) return 0;
1766 set_errno(EPERM); break;
1768 case SS$_NOSUCHNODE:
1769 case SS$_UNREACHABLE:
1770 set_errno(ESRCH); break;
1772 set_errno(ENOMEM); break;
1777 set_vaxc_errno(iss);
1783 /* Routine to convert a VMS status code to a UNIX status code.
1784 ** More tricky than it appears because of conflicting conventions with
1787 ** VMS status codes are a bit mask, with the least significant bit set for
1790 ** Special UNIX status of EVMSERR indicates that no translation is currently
1791 ** available, and programs should check the VMS status code.
1793 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
1797 #ifndef C_FACILITY_NO
1798 #define C_FACILITY_NO 0x350000
1801 #define DCL_IVVERB 0x38090
1804 int Perl_vms_status_to_unix(int vms_status, int child_flag)
1812 /* Assume the best or the worst */
1813 if (vms_status & STS$M_SUCCESS)
1816 unix_status = EVMSERR;
1818 msg_status = vms_status & ~STS$M_CONTROL;
1820 facility = vms_status & STS$M_FAC_NO;
1821 fac_sp = vms_status & STS$M_FAC_SP;
1822 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
1824 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
1830 unix_status = EFAULT;
1832 case SS$_DEVOFFLINE:
1833 unix_status = EBUSY;
1836 unix_status = ENOTCONN;
1844 case SS$_INVFILFOROP:
1848 unix_status = EINVAL;
1850 case SS$_UNSUPPORTED:
1851 unix_status = ENOTSUP;
1856 unix_status = EACCES;
1858 case SS$_DEVICEFULL:
1859 unix_status = ENOSPC;
1862 unix_status = ENODEV;
1864 case SS$_NOSUCHFILE:
1865 case SS$_NOSUCHOBJECT:
1866 unix_status = ENOENT;
1868 case SS$_ABORT: /* Fatal case */
1869 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
1870 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
1871 unix_status = EINTR;
1874 unix_status = E2BIG;
1877 unix_status = ENOMEM;
1880 unix_status = EPERM;
1882 case SS$_NOSUCHNODE:
1883 case SS$_UNREACHABLE:
1884 unix_status = ESRCH;
1887 unix_status = ECHILD;
1890 if ((facility == 0) && (msg_no < 8)) {
1891 /* These are not real VMS status codes so assume that they are
1892 ** already UNIX status codes
1894 unix_status = msg_no;
1900 /* Translate a POSIX exit code to a UNIX exit code */
1901 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
1902 unix_status = (msg_no & 0x07F8) >> 3;
1906 /* Documented traditional behavior for handling VMS child exits */
1907 /*--------------------------------------------------------------*/
1908 if (child_flag != 0) {
1910 /* Success / Informational return 0 */
1911 /*----------------------------------*/
1912 if (msg_no & STS$K_SUCCESS)
1915 /* Warning returns 1 */
1916 /*-------------------*/
1917 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
1920 /* Everything else pass through the severity bits */
1921 /*------------------------------------------------*/
1922 return (msg_no & STS$M_SEVERITY);
1925 /* Normal VMS status to ERRNO mapping attempt */
1926 /*--------------------------------------------*/
1927 switch(msg_status) {
1928 /* case RMS$_EOF: */ /* End of File */
1929 case RMS$_FNF: /* File Not Found */
1930 case RMS$_DNF: /* Dir Not Found */
1931 unix_status = ENOENT;
1933 case RMS$_RNF: /* Record Not Found */
1934 unix_status = ESRCH;
1937 unix_status = ENOTDIR;
1940 unix_status = ENODEV;
1945 unix_status = EBADF;
1948 unix_status = EEXIST;
1952 case LIB$_INVSTRDES:
1954 case LIB$_NOSUCHSYM:
1955 case LIB$_INVSYMNAM:
1957 unix_status = EINVAL;
1963 unix_status = E2BIG;
1965 case RMS$_PRV: /* No privilege */
1966 case RMS$_ACC: /* ACP file access failed */
1967 case RMS$_WLK: /* Device write locked */
1968 unix_status = EACCES;
1970 /* case RMS$_NMF: */ /* No more files */
1978 /* Try to guess at what VMS error status should go with a UNIX errno
1979 * value. This is hard to do as there could be many possible VMS
1980 * error statuses that caused the errno value to be set.
1983 int Perl_unix_status_to_vms(int unix_status)
1985 int test_unix_status;
1987 /* Trivial cases first */
1988 /*---------------------*/
1989 if (unix_status == EVMSERR)
1992 /* Is vaxc$errno sane? */
1993 /*---------------------*/
1994 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
1995 if (test_unix_status == unix_status)
1998 /* If way out of range, must be VMS code already */
1999 /*-----------------------------------------------*/
2000 if (unix_status > EVMSERR)
2003 /* If out of range, punt */
2004 /*-----------------------*/
2005 if (unix_status > __ERRNO_MAX)
2009 /* Ok, now we have to do it the hard way. */
2010 /*----------------------------------------*/
2011 switch(unix_status) {
2012 case 0: return SS$_NORMAL;
2013 case EPERM: return SS$_NOPRIV;
2014 case ENOENT: return SS$_NOSUCHOBJECT;
2015 case ESRCH: return SS$_UNREACHABLE;
2016 case EINTR: return SS$_ABORT;
2019 case E2BIG: return SS$_BUFFEROVF;
2021 case EBADF: return RMS$_IFI;
2022 case ECHILD: return SS$_NONEXPR;
2024 case ENOMEM: return SS$_INSFMEM;
2025 case EACCES: return SS$_FILACCERR;
2026 case EFAULT: return SS$_ACCVIO;
2028 case EBUSY: return SS$_DEVOFFLINE;
2029 case EEXIST: return RMS$_FEX;
2031 case ENODEV: return SS$_NOSUCHDEV;
2032 case ENOTDIR: return RMS$_DIR;
2034 case EINVAL: return SS$_INVARG;
2040 case ENOSPC: return SS$_DEVICEFULL;
2041 case ESPIPE: return LIB$_INVARG;
2046 case ERANGE: return LIB$_INVARG;
2047 /* case EWOULDBLOCK */
2048 /* case EINPROGRESS */
2051 /* case EDESTADDRREQ */
2053 /* case EPROTOTYPE */
2054 /* case ENOPROTOOPT */
2055 /* case EPROTONOSUPPORT */
2056 /* case ESOCKTNOSUPPORT */
2057 /* case EOPNOTSUPP */
2058 /* case EPFNOSUPPORT */
2059 /* case EAFNOSUPPORT */
2060 /* case EADDRINUSE */
2061 /* case EADDRNOTAVAIL */
2063 /* case ENETUNREACH */
2064 /* case ENETRESET */
2065 /* case ECONNABORTED */
2066 /* case ECONNRESET */
2069 case ENOTCONN: return SS$_CLEARED;
2070 /* case ESHUTDOWN */
2071 /* case ETOOMANYREFS */
2072 /* case ETIMEDOUT */
2073 /* case ECONNREFUSED */
2075 /* case ENAMETOOLONG */
2076 /* case EHOSTDOWN */
2077 /* case EHOSTUNREACH */
2078 /* case ENOTEMPTY */
2090 /* case ECANCELED */
2094 return SS$_UNSUPPORTED;
2100 /* case EABANDONED */
2102 return SS$_ABORT; /* punt */
2105 return SS$_ABORT; /* Should not get here */
2109 /* default piping mailbox size */
2110 #define PERL_BUFSIZ 512
2114 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2116 unsigned long int mbxbufsiz;
2117 static unsigned long int syssize = 0;
2118 unsigned long int dviitm = DVI$_DEVNAM;
2119 char csize[LNM$C_NAMLENGTH+1];
2123 unsigned long syiitm = SYI$_MAXBUF;
2125 * Get the SYSGEN parameter MAXBUF
2127 * If the logical 'PERL_MBX_SIZE' is defined
2128 * use the value of the logical instead of PERL_BUFSIZ, but
2129 * keep the size between 128 and MAXBUF.
2132 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2135 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2136 mbxbufsiz = atoi(csize);
2138 mbxbufsiz = PERL_BUFSIZ;
2140 if (mbxbufsiz < 128) mbxbufsiz = 128;
2141 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2143 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2145 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2146 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2148 } /* end of create_mbx() */
2151 /*{{{ my_popen and my_pclose*/
2153 typedef struct _iosb IOSB;
2154 typedef struct _iosb* pIOSB;
2155 typedef struct _pipe Pipe;
2156 typedef struct _pipe* pPipe;
2157 typedef struct pipe_details Info;
2158 typedef struct pipe_details* pInfo;
2159 typedef struct _srqp RQE;
2160 typedef struct _srqp* pRQE;
2161 typedef struct _tochildbuf CBuf;
2162 typedef struct _tochildbuf* pCBuf;
2165 unsigned short status;
2166 unsigned short count;
2167 unsigned long dvispec;
2170 #pragma member_alignment save
2171 #pragma nomember_alignment quadword
2172 struct _srqp { /* VMS self-relative queue entry */
2173 unsigned long qptr[2];
2175 #pragma member_alignment restore
2176 static RQE RQE_ZERO = {0,0};
2178 struct _tochildbuf {
2181 unsigned short size;
2189 unsigned short chan_in;
2190 unsigned short chan_out;
2192 unsigned int bufsize;
2204 #if defined(PERL_IMPLICIT_CONTEXT)
2205 void *thx; /* Either a thread or an interpreter */
2206 /* pointer, depending on how we're built */
2214 PerlIO *fp; /* file pointer to pipe mailbox */
2215 int useFILE; /* using stdio, not perlio */
2216 int pid; /* PID of subprocess */
2217 int mode; /* == 'r' if pipe open for reading */
2218 int done; /* subprocess has completed */
2219 int waiting; /* waiting for completion/closure */
2220 int closing; /* my_pclose is closing this pipe */
2221 unsigned long completion; /* termination status of subprocess */
2222 pPipe in; /* pipe in to sub */
2223 pPipe out; /* pipe out of sub */
2224 pPipe err; /* pipe of sub's sys$error */
2225 int in_done; /* true when in pipe finished */
2230 struct exit_control_block
2232 struct exit_control_block *flink;
2233 unsigned long int (*exit_routine)();
2234 unsigned long int arg_count;
2235 unsigned long int *status_address;
2236 unsigned long int exit_status;
2239 typedef struct _closed_pipes Xpipe;
2240 typedef struct _closed_pipes* pXpipe;
2242 struct _closed_pipes {
2243 int pid; /* PID of subprocess */
2244 unsigned long completion; /* termination status of subprocess */
2246 #define NKEEPCLOSED 50
2247 static Xpipe closed_list[NKEEPCLOSED];
2248 static int closed_index = 0;
2249 static int closed_num = 0;
2251 #define RETRY_DELAY "0 ::0.20"
2252 #define MAX_RETRY 50
2254 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2255 static unsigned long mypid;
2256 static unsigned long delaytime[2];
2258 static pInfo open_pipes = NULL;
2259 static $DESCRIPTOR(nl_desc, "NL:");
2261 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2265 static unsigned long int
2266 pipe_exit_routine(pTHX)
2269 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2270 int sts, did_stuff, need_eof, j;
2273 flush any pending i/o
2279 PerlIO_flush(info->fp); /* first, flush data */
2281 fflush((FILE *)info->fp);
2287 next we try sending an EOF...ignore if doesn't work, make sure we
2295 _ckvmssts_noperl(sys$setast(0));
2296 if (info->in && !info->in->shut_on_empty) {
2297 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2302 _ckvmssts_noperl(sys$setast(1));
2306 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2308 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2313 _ckvmssts_noperl(sys$setast(0));
2314 if (info->waiting && info->done)
2316 nwait += info->waiting;
2317 _ckvmssts_noperl(sys$setast(1));
2327 _ckvmssts_noperl(sys$setast(0));
2328 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2329 sts = sys$forcex(&info->pid,0,&abort);
2330 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2333 _ckvmssts_noperl(sys$setast(1));
2337 /* again, wait for effect */
2339 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2344 _ckvmssts_noperl(sys$setast(0));
2345 if (info->waiting && info->done)
2347 nwait += info->waiting;
2348 _ckvmssts_noperl(sys$setast(1));
2357 _ckvmssts_noperl(sys$setast(0));
2358 if (!info->done) { /* We tried to be nice . . . */
2359 sts = sys$delprc(&info->pid,0);
2360 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2362 _ckvmssts_noperl(sys$setast(1));
2367 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2368 else if (!(sts & 1)) retsts = sts;
2373 static struct exit_control_block pipe_exitblock =
2374 {(struct exit_control_block *) 0,
2375 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2377 static void pipe_mbxtofd_ast(pPipe p);
2378 static void pipe_tochild1_ast(pPipe p);
2379 static void pipe_tochild2_ast(pPipe p);
2382 popen_completion_ast(pInfo info)
2384 pInfo i = open_pipes;
2389 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2390 closed_list[closed_index].pid = info->pid;
2391 closed_list[closed_index].completion = info->completion;
2393 if (closed_index == NKEEPCLOSED)
2398 if (i == info) break;
2401 if (!i) return; /* unlinked, probably freed too */
2406 Writing to subprocess ...
2407 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2409 chan_out may be waiting for "done" flag, or hung waiting
2410 for i/o completion to child...cancel the i/o. This will
2411 put it into "snarf mode" (done but no EOF yet) that discards
2414 Output from subprocess (stdout, stderr) needs to be flushed and
2415 shut down. We try sending an EOF, but if the mbx is full the pipe
2416 routine should still catch the "shut_on_empty" flag, telling it to
2417 use immediate-style reads so that "mbx empty" -> EOF.
2421 if (info->in && !info->in_done) { /* only for mode=w */
2422 if (info->in->shut_on_empty && info->in->need_wake) {
2423 info->in->need_wake = FALSE;
2424 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2426 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2430 if (info->out && !info->out_done) { /* were we also piping output? */
2431 info->out->shut_on_empty = TRUE;
2432 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2433 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2434 _ckvmssts_noperl(iss);
2437 if (info->err && !info->err_done) { /* we were piping stderr */
2438 info->err->shut_on_empty = TRUE;
2439 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2440 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2441 _ckvmssts_noperl(iss);
2443 _ckvmssts_noperl(sys$setef(pipe_ef));
2447 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2448 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2451 we actually differ from vmstrnenv since we use this to
2452 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2453 are pointing to the same thing
2456 static unsigned short
2457 popen_translate(pTHX_ char *logical, char *result)
2460 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2461 $DESCRIPTOR(d_log,"");
2463 unsigned short length;
2464 unsigned short code;
2466 unsigned short *retlenaddr;
2468 unsigned short l, ifi;
2470 d_log.dsc$a_pointer = logical;
2471 d_log.dsc$w_length = strlen(logical);
2473 itmlst[0].code = LNM$_STRING;
2474 itmlst[0].length = 255;
2475 itmlst[0].buffer_addr = result;
2476 itmlst[0].retlenaddr = &l;
2479 itmlst[1].length = 0;
2480 itmlst[1].buffer_addr = 0;
2481 itmlst[1].retlenaddr = 0;
2483 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2484 if (iss == SS$_NOLOGNAM) {
2488 if (!(iss&1)) lib$signal(iss);
2491 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
2492 strip it off and return the ifi, if any
2495 if (result[0] == 0x1b && result[1] == 0x00) {
2496 memmove(&ifi,result+2,2);
2497 strcpy(result,result+4);
2499 return ifi; /* this is the RMS internal file id */
2502 static void pipe_infromchild_ast(pPipe p);
2505 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2506 inside an AST routine without worrying about reentrancy and which Perl
2507 memory allocator is being used.
2509 We read data and queue up the buffers, then spit them out one at a
2510 time to the output mailbox when the output mailbox is ready for one.
2513 #define INITIAL_TOCHILDQUEUE 2
2516 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2520 char mbx1[64], mbx2[64];
2521 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2522 DSC$K_CLASS_S, mbx1},
2523 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2524 DSC$K_CLASS_S, mbx2};
2525 unsigned int dviitm = DVI$_DEVBUFSIZ;
2529 _ckvmssts(lib$get_vm(&n, &p));
2531 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2532 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2533 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2536 p->shut_on_empty = FALSE;
2537 p->need_wake = FALSE;
2540 p->iosb.status = SS$_NORMAL;
2541 p->iosb2.status = SS$_NORMAL;
2547 #ifdef PERL_IMPLICIT_CONTEXT
2551 n = sizeof(CBuf) + p->bufsize;
2553 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2554 _ckvmssts(lib$get_vm(&n, &b));
2555 b->buf = (char *) b + sizeof(CBuf);
2556 _ckvmssts(lib$insqhi(b, &p->free));
2559 pipe_tochild2_ast(p);
2560 pipe_tochild1_ast(p);
2566 /* reads the MBX Perl is writing, and queues */
2569 pipe_tochild1_ast(pPipe p)
2572 int iss = p->iosb.status;
2573 int eof = (iss == SS$_ENDOFFILE);
2575 #ifdef PERL_IMPLICIT_CONTEXT
2581 p->shut_on_empty = TRUE;
2583 _ckvmssts(sys$dassgn(p->chan_in));
2589 b->size = p->iosb.count;
2590 _ckvmssts(sts = lib$insqhi(b, &p->wait));
2592 p->need_wake = FALSE;
2593 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2596 p->retry = 1; /* initial call */
2599 if (eof) { /* flush the free queue, return when done */
2600 int n = sizeof(CBuf) + p->bufsize;
2602 iss = lib$remqti(&p->free, &b);
2603 if (iss == LIB$_QUEWASEMP) return;
2605 _ckvmssts(lib$free_vm(&n, &b));
2609 iss = lib$remqti(&p->free, &b);
2610 if (iss == LIB$_QUEWASEMP) {
2611 int n = sizeof(CBuf) + p->bufsize;
2612 _ckvmssts(lib$get_vm(&n, &b));
2613 b->buf = (char *) b + sizeof(CBuf);
2619 iss = sys$qio(0,p->chan_in,
2620 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2622 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2623 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2628 /* writes queued buffers to output, waits for each to complete before
2632 pipe_tochild2_ast(pPipe p)
2635 int iss = p->iosb2.status;
2636 int n = sizeof(CBuf) + p->bufsize;
2637 int done = (p->info && p->info->done) ||
2638 iss == SS$_CANCEL || iss == SS$_ABORT;
2639 #if defined(PERL_IMPLICIT_CONTEXT)
2644 if (p->type) { /* type=1 has old buffer, dispose */
2645 if (p->shut_on_empty) {
2646 _ckvmssts(lib$free_vm(&n, &b));
2648 _ckvmssts(lib$insqhi(b, &p->free));
2653 iss = lib$remqti(&p->wait, &b);
2654 if (iss == LIB$_QUEWASEMP) {
2655 if (p->shut_on_empty) {
2657 _ckvmssts(sys$dassgn(p->chan_out));
2658 *p->pipe_done = TRUE;
2659 _ckvmssts(sys$setef(pipe_ef));
2661 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2662 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2666 p->need_wake = TRUE;
2676 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2677 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2679 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2680 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2689 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2692 char mbx1[64], mbx2[64];
2693 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2694 DSC$K_CLASS_S, mbx1},
2695 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2696 DSC$K_CLASS_S, mbx2};
2697 unsigned int dviitm = DVI$_DEVBUFSIZ;
2699 int n = sizeof(Pipe);
2700 _ckvmssts(lib$get_vm(&n, &p));
2701 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2702 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2704 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2705 n = p->bufsize * sizeof(char);
2706 _ckvmssts(lib$get_vm(&n, &p->buf));
2707 p->shut_on_empty = FALSE;
2710 p->iosb.status = SS$_NORMAL;
2711 #if defined(PERL_IMPLICIT_CONTEXT)
2714 pipe_infromchild_ast(p);
2722 pipe_infromchild_ast(pPipe p)
2724 int iss = p->iosb.status;
2725 int eof = (iss == SS$_ENDOFFILE);
2726 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2727 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2728 #if defined(PERL_IMPLICIT_CONTEXT)
2732 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
2733 _ckvmssts(sys$dassgn(p->chan_out));
2738 input shutdown if EOF from self (done or shut_on_empty)
2739 output shutdown if closing flag set (my_pclose)
2740 send data/eof from child or eof from self
2741 otherwise, re-read (snarf of data from child)
2746 if (myeof && p->chan_in) { /* input shutdown */
2747 _ckvmssts(sys$dassgn(p->chan_in));
2752 if (myeof || kideof) { /* pass EOF to parent */
2753 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2754 pipe_infromchild_ast, p,
2757 } else if (eof) { /* eat EOF --- fall through to read*/
2759 } else { /* transmit data */
2760 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2761 pipe_infromchild_ast,p,
2762 p->buf, p->iosb.count, 0, 0, 0, 0));
2768 /* everything shut? flag as done */
2770 if (!p->chan_in && !p->chan_out) {
2771 *p->pipe_done = TRUE;
2772 _ckvmssts(sys$setef(pipe_ef));
2776 /* write completed (or read, if snarfing from child)
2777 if still have input active,
2778 queue read...immediate mode if shut_on_empty so we get EOF if empty
2780 check if Perl reading, generate EOFs as needed
2786 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2787 pipe_infromchild_ast,p,
2788 p->buf, p->bufsize, 0, 0, 0, 0);
2789 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2791 } else { /* send EOFs for extra reads */
2792 p->iosb.status = SS$_ENDOFFILE;
2793 p->iosb.dvispec = 0;
2794 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2796 pipe_infromchild_ast, p, 0, 0, 0, 0));
2802 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2806 unsigned long dviitm = DVI$_DEVBUFSIZ;
2808 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2809 DSC$K_CLASS_S, mbx};
2810 int n = sizeof(Pipe);
2812 /* things like terminals and mbx's don't need this filter */
2813 if (fd && fstat(fd,&s) == 0) {
2814 unsigned long dviitm = DVI$_DEVCHAR, devchar;
2815 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2816 DSC$K_CLASS_S, s.st_dev};
2818 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2819 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
2820 strcpy(out, s.st_dev);
2825 _ckvmssts(lib$get_vm(&n, &p));
2826 p->fd_out = dup(fd);
2827 create_mbx(aTHX_ &p->chan_in, &d_mbx);
2828 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2829 n = (p->bufsize+1) * sizeof(char);
2830 _ckvmssts(lib$get_vm(&n, &p->buf));
2831 p->shut_on_empty = FALSE;
2836 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2837 pipe_mbxtofd_ast, p,
2838 p->buf, p->bufsize, 0, 0, 0, 0));
2844 pipe_mbxtofd_ast(pPipe p)
2846 int iss = p->iosb.status;
2847 int done = p->info->done;
2849 int eof = (iss == SS$_ENDOFFILE);
2850 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2851 int err = !(iss&1) && !eof;
2852 #if defined(PERL_IMPLICIT_CONTEXT)
2856 if (done && myeof) { /* end piping */
2858 sys$dassgn(p->chan_in);
2859 *p->pipe_done = TRUE;
2860 _ckvmssts(sys$setef(pipe_ef));
2864 if (!err && !eof) { /* good data to send to file */
2865 p->buf[p->iosb.count] = '\n';
2866 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2869 if (p->retry < MAX_RETRY) {
2870 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2880 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2881 pipe_mbxtofd_ast, p,
2882 p->buf, p->bufsize, 0, 0, 0, 0);
2883 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2888 typedef struct _pipeloc PLOC;
2889 typedef struct _pipeloc* pPLOC;
2893 char dir[NAM$C_MAXRSS+1];
2895 static pPLOC head_PLOC = 0;
2898 free_pipelocs(pTHX_ void *head)
2901 pPLOC *pHead = (pPLOC *)head;
2913 store_pipelocs(pTHX)
2922 char temp[NAM$C_MAXRSS+1];
2926 free_pipelocs(aTHX_ &head_PLOC);
2928 /* the . directory from @INC comes last */
2930 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2931 p->next = head_PLOC;
2933 strcpy(p->dir,"./");
2935 /* get the directory from $^X */
2937 #ifdef PERL_IMPLICIT_CONTEXT
2938 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2940 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2942 strcpy(temp, PL_origargv[0]);
2943 x = strrchr(temp,']');
2945 x = strrchr(temp,'>');
2947 /* It could be a UNIX path */
2948 x = strrchr(temp,'/');
2954 /* Got a bare name, so use default directory */
2959 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2960 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2961 p->next = head_PLOC;
2963 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2964 p->dir[NAM$C_MAXRSS] = '\0';
2968 /* reverse order of @INC entries, skip "." since entered above */
2970 #ifdef PERL_IMPLICIT_CONTEXT
2973 if (PL_incgv) av = GvAVn(PL_incgv);
2975 for (i = 0; av && i <= AvFILL(av); i++) {
2976 dirsv = *av_fetch(av,i,TRUE);
2978 if (SvROK(dirsv)) continue;
2979 dir = SvPVx(dirsv,n_a);
2980 if (strcmp(dir,".") == 0) continue;
2981 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2984 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2985 p->next = head_PLOC;
2987 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2988 p->dir[NAM$C_MAXRSS] = '\0';
2991 /* most likely spot (ARCHLIB) put first in the list */
2994 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2995 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2996 p->next = head_PLOC;
2998 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2999 p->dir[NAM$C_MAXRSS] = '\0';
3008 static int vmspipe_file_status = 0;
3009 static char vmspipe_file[NAM$C_MAXRSS+1];
3011 /* already found? Check and use ... need read+execute permission */
3013 if (vmspipe_file_status == 1) {
3014 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3015 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3016 return vmspipe_file;
3018 vmspipe_file_status = 0;
3021 /* scan through stored @INC, $^X */
3023 if (vmspipe_file_status == 0) {
3024 char file[NAM$C_MAXRSS+1];
3025 pPLOC p = head_PLOC;
3028 strcpy(file, p->dir);
3029 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3030 file[NAM$C_MAXRSS] = '\0';
3033 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3035 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3036 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3037 vmspipe_file_status = 1;
3038 return vmspipe_file;
3041 vmspipe_file_status = -1; /* failed, use tempfiles */
3048 vmspipe_tempfile(pTHX)
3050 char file[NAM$C_MAXRSS+1];
3052 static int index = 0;
3056 /* create a tempfile */
3058 /* we can't go from W, shr=get to R, shr=get without
3059 an intermediate vulnerable state, so don't bother trying...
3061 and lib$spawn doesn't shr=put, so have to close the write
3063 So... match up the creation date/time and the FID to
3064 make sure we're dealing with the same file
3069 if (!decc_filename_unix_only) {
3070 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3071 fp = fopen(file,"w");
3073 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3074 fp = fopen(file,"w");
3076 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3077 fp = fopen(file,"w");
3082 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3083 fp = fopen(file,"w");
3085 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3086 fp = fopen(file,"w");
3088 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3089 fp = fopen(file,"w");
3093 if (!fp) return 0; /* we're hosed */
3095 fprintf(fp,"$! 'f$verify(0)'\n");
3096 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3097 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3098 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3099 fprintf(fp,"$ perl_on = \"set noon\"\n");
3100 fprintf(fp,"$ perl_exit = \"exit\"\n");
3101 fprintf(fp,"$ perl_del = \"delete\"\n");
3102 fprintf(fp,"$ pif = \"if\"\n");
3103 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3104 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3105 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3106 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3107 fprintf(fp,"$! --- build command line to get max possible length\n");
3108 fprintf(fp,"$c=perl_popen_cmd0\n");
3109 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3110 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3111 fprintf(fp,"$x=perl_popen_cmd3\n");
3112 fprintf(fp,"$c=c+x\n");
3113 fprintf(fp,"$ perl_on\n");
3114 fprintf(fp,"$ 'c'\n");
3115 fprintf(fp,"$ perl_status = $STATUS\n");
3116 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3117 fprintf(fp,"$ perl_exit 'perl_status'\n");
3120 fgetname(fp, file, 1);
3121 fstat(fileno(fp), (struct stat *)&s0);
3124 if (decc_filename_unix_only)
3125 do_tounixspec(file, file, 0);
3126 fp = fopen(file,"r","shr=get");
3128 fstat(fileno(fp), (struct stat *)&s1);
3130 #if defined(_USE_STD_STAT)
3131 cmp_result = s0.crtl_stat.st_ino != s1.crtl_stat.st_ino;
3133 cmp_result = memcmp(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino, 6);
3135 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3146 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3148 static int handler_set_up = FALSE;
3149 unsigned long int sts, flags = CLI$M_NOWAIT;
3150 /* The use of a GLOBAL table (as was done previously) rendered
3151 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3152 * environment. Hence we've switched to LOCAL symbol table.
3154 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3156 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3157 char in[512], out[512], err[512], mbx[512];
3159 char tfilebuf[NAM$C_MAXRSS+1];
3161 char cmd_sym_name[20];
3162 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3163 DSC$K_CLASS_S, symbol};
3164 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3166 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3167 DSC$K_CLASS_S, cmd_sym_name};
3168 struct dsc$descriptor_s *vmscmd;
3169 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3170 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3171 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3173 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3175 /* once-per-program initialization...
3176 note that the SETAST calls and the dual test of pipe_ef
3177 makes sure that only the FIRST thread through here does
3178 the initialization...all other threads wait until it's
3181 Yeah, uglier than a pthread call, it's got all the stuff inline
3182 rather than in a separate routine.
3186 _ckvmssts(sys$setast(0));
3188 unsigned long int pidcode = JPI$_PID;
3189 $DESCRIPTOR(d_delay, RETRY_DELAY);
3190 _ckvmssts(lib$get_ef(&pipe_ef));
3191 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3192 _ckvmssts(sys$bintim(&d_delay, delaytime));
3194 if (!handler_set_up) {
3195 _ckvmssts(sys$dclexh(&pipe_exitblock));
3196 handler_set_up = TRUE;
3198 _ckvmssts(sys$setast(1));
3201 /* see if we can find a VMSPIPE.COM */
3204 vmspipe = find_vmspipe(aTHX);
3206 strcpy(tfilebuf+1,vmspipe);
3207 } else { /* uh, oh...we're in tempfile hell */
3208 tpipe = vmspipe_tempfile(aTHX);
3209 if (!tpipe) { /* a fish popular in Boston */
3210 if (ckWARN(WARN_PIPE)) {
3211 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3215 fgetname(tpipe,tfilebuf+1,1);
3217 vmspipedsc.dsc$a_pointer = tfilebuf;
3218 vmspipedsc.dsc$w_length = strlen(tfilebuf);
3220 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3223 case RMS$_FNF: case RMS$_DNF:
3224 set_errno(ENOENT); break;
3226 set_errno(ENOTDIR); break;
3228 set_errno(ENODEV); break;
3230 set_errno(EACCES); break;
3232 set_errno(EINVAL); break;
3233 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3234 set_errno(E2BIG); break;
3235 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3236 _ckvmssts(sts); /* fall through */
3237 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3240 set_vaxc_errno(sts);
3241 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3242 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3248 _ckvmssts(lib$get_vm(&n, &info));
3250 strcpy(mode,in_mode);
3253 info->completion = 0;
3254 info->closing = FALSE;
3261 info->in_done = TRUE;
3262 info->out_done = TRUE;
3263 info->err_done = TRUE;
3264 in[0] = out[0] = err[0] = '\0';
3266 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
3270 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
3275 if (*mode == 'r') { /* piping from subroutine */
3277 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3279 info->out->pipe_done = &info->out_done;
3280 info->out_done = FALSE;
3281 info->out->info = info;
3283 if (!info->useFILE) {
3284 info->fp = PerlIO_open(mbx, mode);
3286 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3287 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3290 if (!info->fp && info->out) {
3291 sys$cancel(info->out->chan_out);
3293 while (!info->out_done) {
3295 _ckvmssts(sys$setast(0));
3296 done = info->out_done;
3297 if (!done) _ckvmssts(sys$clref(pipe_ef));
3298 _ckvmssts(sys$setast(1));
3299 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3302 if (info->out->buf) {
3303 n = info->out->bufsize * sizeof(char);
3304 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3307 _ckvmssts(lib$free_vm(&n, &info->out));
3309 _ckvmssts(lib$free_vm(&n, &info));
3314 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3316 info->err->pipe_done = &info->err_done;
3317 info->err_done = FALSE;
3318 info->err->info = info;
3321 } else if (*mode == 'w') { /* piping to subroutine */
3323 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3325 info->out->pipe_done = &info->out_done;
3326 info->out_done = FALSE;
3327 info->out->info = info;
3330 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3332 info->err->pipe_done = &info->err_done;
3333 info->err_done = FALSE;
3334 info->err->info = info;
3337 info->in = pipe_tochild_setup(aTHX_ in,mbx);
3338 if (!info->useFILE) {
3339 info->fp = PerlIO_open(mbx, mode);
3341 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3342 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3346 info->in->pipe_done = &info->in_done;
3347 info->in_done = FALSE;
3348 info->in->info = info;
3352 if (!info->fp && info->in) {
3354 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3355 0, 0, 0, 0, 0, 0, 0, 0));
3357 while (!info->in_done) {
3359 _ckvmssts(sys$setast(0));
3360 done = info->in_done;
3361 if (!done) _ckvmssts(sys$clref(pipe_ef));
3362 _ckvmssts(sys$setast(1));
3363 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3366 if (info->in->buf) {
3367 n = info->in->bufsize * sizeof(char);
3368 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3371 _ckvmssts(lib$free_vm(&n, &info->in));
3373 _ckvmssts(lib$free_vm(&n, &info));
3379 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
3380 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3382 info->out->pipe_done = &info->out_done;
3383 info->out_done = FALSE;
3384 info->out->info = info;
3387 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3389 info->err->pipe_done = &info->err_done;
3390 info->err_done = FALSE;
3391 info->err->info = info;
3395 symbol[MAX_DCL_SYMBOL] = '\0';
3397 strncpy(symbol, in, MAX_DCL_SYMBOL);
3398 d_symbol.dsc$w_length = strlen(symbol);
3399 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3401 strncpy(symbol, err, MAX_DCL_SYMBOL);
3402 d_symbol.dsc$w_length = strlen(symbol);
3403 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3405 strncpy(symbol, out, MAX_DCL_SYMBOL);
3406 d_symbol.dsc$w_length = strlen(symbol);
3407 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3409 p = vmscmd->dsc$a_pointer;
3410 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
3411 if (*p == '$') p++; /* remove leading $ */
3412 while (*p == ' ' || *p == '\t') p++;
3414 for (j = 0; j < 4; j++) {
3415 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3416 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3418 strncpy(symbol, p, MAX_DCL_SYMBOL);
3419 d_symbol.dsc$w_length = strlen(symbol);
3420 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3422 if (strlen(p) > MAX_DCL_SYMBOL) {
3423 p += MAX_DCL_SYMBOL;
3428 _ckvmssts(sys$setast(0));
3429 info->next=open_pipes; /* prepend to list */
3431 _ckvmssts(sys$setast(1));
3432 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3433 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
3434 * have SYS$COMMAND if we need it.
3436 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3437 0, &info->pid, &info->completion,
3438 0, popen_completion_ast,info,0,0,0));
3440 /* if we were using a tempfile, close it now */
3442 if (tpipe) fclose(tpipe);
3444 /* once the subprocess is spawned, it has copied the symbols and
3445 we can get rid of ours */
3447 for (j = 0; j < 4; j++) {
3448 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3449 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3450 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3452 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
3453 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3454 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3455 vms_execfree(vmscmd);
3457 #ifdef PERL_IMPLICIT_CONTEXT
3460 PL_forkprocess = info->pid;
3465 _ckvmssts(sys$setast(0));
3467 if (!done) _ckvmssts(sys$clref(pipe_ef));
3468 _ckvmssts(sys$setast(1));
3469 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3471 *psts = info->completion;
3472 /* Caller thinks it is open and tries to close it. */
3473 /* This causes some problems, as it changes the error status */
3474 /* my_pclose(info->fp); */
3479 } /* end of safe_popen */
3482 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
3484 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3488 TAINT_PROPER("popen");
3489 PERL_FLUSHALL_FOR_CHILD;
3490 return safe_popen(aTHX_ cmd,mode,&sts);
3495 /*{{{ I32 my_pclose(PerlIO *fp)*/
3496 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3498 pInfo info, last = NULL;
3499 unsigned long int retsts;
3502 for (info = open_pipes; info != NULL; last = info, info = info->next)
3503 if (info->fp == fp) break;
3505 if (info == NULL) { /* no such pipe open */
3506 set_errno(ECHILD); /* quoth POSIX */
3507 set_vaxc_errno(SS$_NONEXPR);
3511 /* If we were writing to a subprocess, insure that someone reading from
3512 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
3513 * produce an EOF record in the mailbox.
3515 * well, at least sometimes it *does*, so we have to watch out for
3516 * the first EOF closing the pipe (and DASSGN'ing the channel)...
3520 PerlIO_flush(info->fp); /* first, flush data */
3522 fflush((FILE *)info->fp);
3525 _ckvmssts(sys$setast(0));
3526 info->closing = TRUE;
3527 done = info->done && info->in_done && info->out_done && info->err_done;
3528 /* hanging on write to Perl's input? cancel it */
3529 if (info->mode == 'r' && info->out && !info->out_done) {
3530 if (info->out->chan_out) {
3531 _ckvmssts(sys$cancel(info->out->chan_out));
3532 if (!info->out->chan_in) { /* EOF generation, need AST */
3533 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3537 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
3538 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3540 _ckvmssts(sys$setast(1));
3543 PerlIO_close(info->fp);
3545 fclose((FILE *)info->fp);
3548 we have to wait until subprocess completes, but ALSO wait until all
3549 the i/o completes...otherwise we'll be freeing the "info" structure
3550 that the i/o ASTs could still be using...
3554 _ckvmssts(sys$setast(0));
3555 done = info->done && info->in_done && info->out_done && info->err_done;
3556 if (!done) _ckvmssts(sys$clref(pipe_ef));
3557 _ckvmssts(sys$setast(1));
3558 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3560 retsts = info->completion;
3562 /* remove from list of open pipes */
3563 _ckvmssts(sys$setast(0));
3564 if (last) last->next = info->next;
3565 else open_pipes = info->next;
3566 _ckvmssts(sys$setast(1));
3568 /* free buffers and structures */
3571 if (info->in->buf) {
3572 n = info->in->bufsize * sizeof(char);
3573 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3576 _ckvmssts(lib$free_vm(&n, &info->in));
3579 if (info->out->buf) {
3580 n = info->out->bufsize * sizeof(char);
3581 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3584 _ckvmssts(lib$free_vm(&n, &info->out));
3587 if (info->err->buf) {
3588 n = info->err->bufsize * sizeof(char);
3589 _ckvmssts(lib$free_vm(&n, &info->err->buf));
3592 _ckvmssts(lib$free_vm(&n, &info->err));
3595 _ckvmssts(lib$free_vm(&n, &info));
3599 } /* end of my_pclose() */
3601 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3602 /* Roll our own prototype because we want this regardless of whether
3603 * _VMS_WAIT is defined.
3605 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3607 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3608 created with popen(); otherwise partially emulate waitpid() unless
3609 we have a suitable one from the CRTL that came with VMS 7.2 and later.
3610 Also check processes not considered by the CRTL waitpid().
3612 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3614 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3621 if (statusp) *statusp = 0;
3623 for (info = open_pipes; info != NULL; info = info->next)
3624 if (info->pid == pid) break;
3626 if (info != NULL) { /* we know about this child */
3627 while (!info->done) {
3628 _ckvmssts(sys$setast(0));
3630 if (!done) _ckvmssts(sys$clref(pipe_ef));
3631 _ckvmssts(sys$setast(1));
3632 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3635 if (statusp) *statusp = info->completion;
3639 /* child that already terminated? */
3641 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3642 if (closed_list[j].pid == pid) {
3643 if (statusp) *statusp = closed_list[j].completion;
3648 /* fall through if this child is not one of our own pipe children */
3650 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3652 /* waitpid() became available in the CRTL as of VMS 7.0, but only
3653 * in 7.2 did we get a version that fills in the VMS completion
3654 * status as Perl has always tried to do.
3657 sts = __vms_waitpid( pid, statusp, flags );
3659 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3662 /* If the real waitpid tells us the child does not exist, we
3663 * fall through here to implement waiting for a child that
3664 * was created by some means other than exec() (say, spawned
3665 * from DCL) or to wait for a process that is not a subprocess
3666 * of the current process.
3669 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3672 $DESCRIPTOR(intdsc,"0 00:00:01");
3673 unsigned long int ownercode = JPI$_OWNER, ownerpid;
3674 unsigned long int pidcode = JPI$_PID, mypid;
3675 unsigned long int interval[2];
3676 unsigned int jpi_iosb[2];
3677 struct itmlst_3 jpilist[2] = {
3678 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
3683 /* Sorry folks, we don't presently implement rooting around for
3684 the first child we can find, and we definitely don't want to
3685 pass a pid of -1 to $getjpi, where it is a wildcard operation.
3691 /* Get the owner of the child so I can warn if it's not mine. If the
3692 * process doesn't exist or I don't have the privs to look at it,
3693 * I can go home early.
3695 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3696 if (sts & 1) sts = jpi_iosb[0];
3708 set_vaxc_errno(sts);
3712 if (ckWARN(WARN_EXEC)) {
3713 /* remind folks they are asking for non-standard waitpid behavior */
3714 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3715 if (ownerpid != mypid)
3716 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3717 "waitpid: process %x is not a child of process %x",
3721 /* simply check on it once a second until it's not there anymore. */
3723 _ckvmssts(sys$bintim(&intdsc,interval));
3724 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3725 _ckvmssts(sys$schdwk(0,0,interval,0));
3726 _ckvmssts(sys$hiber());
3728 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3733 } /* end of waitpid() */
3738 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3740 my_gconvert(double val, int ndig, int trail, char *buf)
3742 static char __gcvtbuf[DBL_DIG+1];
3745 loc = buf ? buf : __gcvtbuf;
3747 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
3749 sprintf(loc,"%.*g",ndig,val);
3755 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3756 return gcvt(val,ndig,loc);
3759 loc[0] = '0'; loc[1] = '\0';
3766 #if 1 /* defined(__VAX) || !defined(NAML$C_MAXRSS) */
3767 static int rms_free_search_context(struct FAB * fab)
3771 nam = fab->fab$l_nam;
3772 nam->nam$b_nop |= NAM$M_SYNCHK;
3773 nam->nam$l_rlf = NULL;
3775 return sys$parse(fab, NULL, NULL);
3778 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
3779 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
3780 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
3781 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
3782 #define rms_nam_esll(nam) nam.nam$b_esl
3783 #define rms_nam_esl(nam) nam.nam$b_esl
3784 #define rms_nam_name(nam) nam.nam$l_name
3785 #define rms_nam_namel(nam) nam.nam$l_name
3786 #define rms_nam_type(nam) nam.nam$l_type
3787 #define rms_nam_typel(nam) nam.nam$l_type
3788 #define rms_nam_ver(nam) nam.nam$l_ver
3789 #define rms_nam_verl(nam) nam.nam$l_ver
3790 #define rms_nam_rsll(nam) nam.nam$b_rsl
3791 #define rms_nam_rsl(nam) nam.nam$b_rsl
3792 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
3793 #define rms_set_fna(fab, nam, name, size) \
3794 fab.fab$b_fns = size; fab.fab$l_fna = name;
3795 #define rms_get_fna(fab, nam) fab.fab$l_fna
3796 #define rms_set_dna(fab, nam, name, size) \
3797 fab.fab$b_dns = size; fab.fab$l_dna = name;
3798 #define rms_nam_dns(fab, nam) fab.fab$b_dns;
3799 #define rms_set_esa(fab, nam, name, size) \
3800 nam.nam$b_ess = size; nam.nam$l_esa = name;
3801 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3802 nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
3803 #define rms_set_rsa(nam, name, size) \
3804 nam.nam$l_rsa = name; nam.nam$b_rss = size;
3805 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3806 nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
3809 static int rms_free_search_context(struct FAB * fab)
3813 nam = fab->fab$l_naml;
3814 nam->naml$b_nop |= NAM$M_SYNCHK;
3815 nam->naml$l_rlf = NULL;
3816 nam->naml$l_long_defname_size = 0;
3818 return sys$parse(fab, NULL, NULL);
3821 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
3822 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
3823 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
3824 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
3825 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
3826 #define rms_nam_esl(nam) nam.naml$b_esl
3827 #define rms_nam_name(nam) nam.naml$l_name
3828 #define rms_nam_namel(nam) nam.naml$l_long_name
3829 #define rms_nam_type(nam) nam.naml$l_type
3830 #define rms_nam_typel(nam) nam.naml$l_long_type
3831 #define rms_nam_ver(nam) nam.naml$l_ver
3832 #define rms_nam_verl(nam) nam.naml$l_long_ver
3833 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
3834 #define rms_nam_rsl(nam) nam.naml$b_rsl
3835 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
3836 #define rms_set_fna(fab, nam, name, size) \
3837 fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
3838 nam.naml$l_long_filename_size = size; \
3839 nam.naml$l_long_filename = name
3840 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
3841 #define rms_set_dna(fab, nam, name, size) \
3842 fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
3843 nam.naml$l_long_defname_size = size; \
3844 nam.naml$l_long_defname = name
3845 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
3846 #define rms_set_esa(fab, nam, name, size) \
3847 nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
3848 nam.naml$l_long_expand_alloc = size; \
3849 nam.naml$l_long_expand = name
3850 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3851 nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
3852 nam.naml$l_long_expand = l_name; \
3853 nam.naml$l_long_expand_alloc = l_size;
3854 #define rms_set_rsa(nam, name, size) \
3855 nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
3856 nam.naml$l_long_result = name; \
3857 nam.naml$l_long_result_alloc = size;
3858 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3859 nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
3860 nam.naml$l_long_result = l_name; \
3861 nam.naml$l_long_result_alloc = l_size;
3866 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3867 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
3868 * to expand file specification. Allows for a single default file
3869 * specification and a simple mask of options. If outbuf is non-NULL,
3870 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3871 * the resultant file specification is placed. If outbuf is NULL, the
3872 * resultant file specification is placed into a static buffer.
3873 * The third argument, if non-NULL, is taken to be a default file
3874 * specification string. The fourth argument is unused at present.
3875 * rmesexpand() returns the address of the resultant string if
3876 * successful, and NULL on error.
3878 * New functionality for previously unused opts value:
3879 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
3881 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
3883 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
3884 /* ODS-2 only version */
3886 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3888 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
3889 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
3890 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3891 struct FAB myfab = cc$rms_fab;
3892 struct NAM mynam = cc$rms_nam;
3894 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3897 if (!filespec || !*filespec) {
3898 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3902 if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
3903 else outbuf = __rmsexpand_retbuf;
3905 isunix = is_unix_filespec(filespec);
3907 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
3912 filespec = vmsfspec;
3915 myfab.fab$l_fna = (char *)filespec; /* cast ok for read only pointer */
3916 myfab.fab$b_fns = strlen(filespec);
3917 myfab.fab$l_nam = &mynam;
3919 if (defspec && *defspec) {
3920 if (strchr(defspec,'/') != NULL) {
3921 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
3928 myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
3929 myfab.fab$b_dns = strlen(defspec);
3932 mynam.nam$l_esa = esa;
3933 mynam.nam$b_ess = sizeof esa;
3934 mynam.nam$l_rsa = outbuf;
3935 mynam.nam$b_rss = NAM$C_MAXRSS;
3937 #ifdef NAM$M_NO_SHORT_UPCASE
3938 if (decc_efs_case_preserve)
3939 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3942 retsts = sys$parse(&myfab,0,0);
3943 if (!(retsts & 1)) {
3944 mynam.nam$b_nop |= NAM$M_SYNCHK;
3945 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
3946 retsts = sys$parse(&myfab,0,0);
3947 if (retsts & 1) goto expanded;
3949 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3950 sts = sys$parse(&myfab,0,0); /* Free search context */
3951 if (out) Safefree(out);
3952 set_vaxc_errno(retsts);
3953 if (retsts == RMS$_PRV) set_errno(EACCES);
3954 else if (retsts == RMS$_DEV) set_errno(ENODEV);
3955 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3956 else set_errno(EVMSERR);
3959 retsts = sys$search(&myfab,0,0);
3960 if (!(retsts & 1) && retsts != RMS$_FNF) {
3961 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3962 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
3963 if (out) Safefree(out);
3964 set_vaxc_errno(retsts);
3965 if (retsts == RMS$_PRV) set_errno(EACCES);
3966 else set_errno(EVMSERR);
3970 /* If the input filespec contained any lowercase characters,
3971 * downcase the result for compatibility with Unix-minded code. */
3973 if (!decc_efs_case_preserve) {
3974 for (out = myfab.fab$l_fna; *out; out++)
3975 if (islower(*out)) { haslower = 1; break; }
3977 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3978 else { out = esa; speclen = mynam.nam$b_esl; }
3979 /* Trim off null fields added by $PARSE
3980 * If type > 1 char, must have been specified in original or default spec
3981 * (not true for version; $SEARCH may have added version of existing file).
3983 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3984 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3985 (mynam.nam$l_ver - mynam.nam$l_type == 1);
3986 if (trimver || trimtype) {
3987 if (defspec && *defspec) {
3988 char defesa[NAM$C_MAXRSS];
3989 struct FAB deffab = cc$rms_fab;
3990 struct NAM defnam = cc$rms_nam;
3992 deffab.fab$l_nam = &defnam;
3993 /* cast below ok for read only pointer */
3994 deffab.fab$l_fna = (char *)defspec; deffab.fab$b_fns = myfab.fab$b_dns;
3995 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
3996 defnam.nam$b_nop = NAM$M_SYNCHK;
3997 #ifdef NAM$M_NO_SHORT_UPCASE
3998 if (decc_efs_case_preserve)
3999 defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4001 if (sys$parse(&deffab,0,0) & 1) {
4002 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
4003 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4007 if (*mynam.nam$l_ver != '\"')
4008 speclen = mynam.nam$l_ver - out;
4011 /* If we didn't already trim version, copy down */
4012 if (speclen > mynam.nam$l_ver - out)
4013 memmove(mynam.nam$l_type, mynam.nam$l_ver,
4014 speclen - (mynam.nam$l_ver - out));
4015 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4018 /* If we just had a directory spec on input, $PARSE "helpfully"
4019 * adds an empty name and type for us */
4020 if (mynam.nam$l_name == mynam.nam$l_type &&
4021 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
4022 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4023 speclen = mynam.nam$l_name - out;
4025 /* Posix format specifications must have matching quotes */
4026 if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4027 if ((speclen > 1) && (out[speclen-1] != '\"')) {
4028 out[speclen] = '\"';
4033 out[speclen] = '\0';
4034 if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4036 /* Have we been working with an expanded, but not resultant, spec? */
4037 /* Also, convert back to Unix syntax if necessary. */
4038 if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4041 if (!mynam.nam$b_rsl) {
4043 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4045 else strcpy(outbuf,esa);
4048 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4049 strcpy(outbuf,tmpfspec);
4051 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4052 mynam.nam$l_rsa = NULL;
4053 mynam.nam$b_rss = 0;
4054 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
4058 /* ODS-5 supporting routine */
4060 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4062 static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4063 char * vmsfspec, *tmpfspec;
4064 char * esa, *cp, *out = NULL;
4067 struct FAB myfab = cc$rms_fab;
4068 rms_setup_nam(mynam);
4070 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4073 if (!filespec || !*filespec) {
4074 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4078 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4079 else outbuf = __rmsexpand_retbuf;
4085 isunix = is_unix_filespec(filespec);
4087 Newx(vmsfspec, VMS_MAXRSS, char);
4088 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4094 filespec = vmsfspec;
4096 /* Unless we are forcing to VMS format, a UNIX input means
4097 * UNIX output, and that requires long names to be used
4099 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4100 opts |= PERL_RMSEXPAND_M_LONG;
4106 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4107 rms_bind_fab_nam(myfab, mynam);
4109 if (defspec && *defspec) {
4111 t_isunix = is_unix_filespec(defspec);
4113 Newx(tmpfspec, VMS_MAXRSS, char);
4114 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4116 if (vmsfspec != NULL)
4124 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4127 Newx(esa, NAM$C_MAXRSS + 1, char);
4128 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4129 Newx(esal, NAML$C_MAXRSS + 1, char);
4131 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
4133 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4134 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4137 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4138 Newx(outbufl, VMS_MAXRSS, char);
4139 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4141 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4145 #ifdef NAM$M_NO_SHORT_UPCASE
4146 if (decc_efs_case_preserve)
4147 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4150 /* First attempt to parse as an existing file */
4151 retsts = sys$parse(&myfab,0,0);
4152 if (!(retsts & STS$K_SUCCESS)) {
4154 /* Could not find the file, try as syntax only if error is not fatal */
4155 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4156 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4157 retsts = sys$parse(&myfab,0,0);
4158 if (retsts & STS$K_SUCCESS) goto expanded;
4161 /* Still could not parse the file specification */
4162 /*----------------------------------------------*/
4163 sts = rms_free_search_context(&myfab); /* Free search context */
4164 if (out) Safefree(out);
4165 if (tmpfspec != NULL)
4167 if (vmsfspec != NULL)
4171 set_vaxc_errno(retsts);
4172 if (retsts == RMS$_PRV) set_errno(EACCES);
4173 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4174 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4175 else set_errno(EVMSERR);
4178 retsts = sys$search(&myfab,0,0);
4179 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4180 sts = rms_free_search_context(&myfab); /* Free search context */
4181 if (out) Safefree(out);
4182 if (tmpfspec != NULL)
4184 if (vmsfspec != NULL)
4188 set_vaxc_errno(retsts);
4189 if (retsts == RMS$_PRV) set_errno(EACCES);
4190 else set_errno(EVMSERR);
4194 /* If the input filespec contained any lowercase characters,
4195 * downcase the result for compatibility with Unix-minded code. */
4197 if (!decc_efs_case_preserve) {
4198 for (out = rms_get_fna(myfab, mynam); *out; out++)
4199 if (islower(*out)) { haslower = 1; break; }
4202 /* Is a long or a short name expected */
4203 /*------------------------------------*/
4204 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4205 if (rms_nam_rsll(mynam)) {
4207 speclen = rms_nam_rsll(mynam);
4210 out = esal; /* Not esa */
4211 speclen = rms_nam_esll(mynam);
4215 if (rms_nam_rsl(mynam)) {
4217 speclen = rms_nam_rsl(mynam);
4220 out = esa; /* Not esal */
4221 speclen = rms_nam_esl(mynam);
4224 /* Trim off null fields added by $PARSE
4225 * If type > 1 char, must have been specified in original or default spec
4226 * (not true for version; $SEARCH may have added version of existing file).
4228 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4229 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4230 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4231 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4234 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4235 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4237 if (trimver || trimtype) {
4238 if (defspec && *defspec) {
4239 char *defesal = NULL;
4240 Newx(defesal, NAML$C_MAXRSS + 1, char);
4241 if (defesal != NULL) {
4242 struct FAB deffab = cc$rms_fab;
4243 rms_setup_nam(defnam);
4245 rms_bind_fab_nam(deffab, defnam);
4249 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4251 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4253 rms_set_nam_nop(defnam, 0);
4254 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4255 #ifdef NAM$M_NO_SHORT_UPCASE
4256 if (decc_efs_case_preserve)
4257 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4259 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4261 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4264 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4271 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4272 if (*(rms_nam_verl(mynam)) != '\"')
4273 speclen = rms_nam_verl(mynam) - out;
4276 if (*(rms_nam_ver(mynam)) != '\"')
4277 speclen = rms_nam_ver(mynam) - out;
4281 /* If we didn't already trim version, copy down */
4282 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4283 if (speclen > rms_nam_verl(mynam) - out)
4285 (rms_nam_typel(mynam),
4286 rms_nam_verl(mynam),
4287 speclen - (rms_nam_verl(mynam) - out));
4288 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4291 if (speclen > rms_nam_ver(mynam) - out)
4293 (rms_nam_type(mynam),
4295 speclen - (rms_nam_ver(mynam) - out));
4296 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4301 /* Done with these copies of the input files */
4302 /*-------------------------------------------*/
4303 if (vmsfspec != NULL)
4305 if (tmpfspec != NULL)
4308 /* If we just had a directory spec on input, $PARSE "helpfully"
4309 * adds an empty name and type for us */
4310 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4311 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4312 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
4313 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4314 speclen = rms_nam_namel(mynam) - out;
4317 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4318 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
4319 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4320 speclen = rms_nam_name(mynam) - out;
4323 /* Posix format specifications must have matching quotes */
4324 if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4325 if ((speclen > 1) && (out[speclen-1] != '\"')) {
4326 out[speclen] = '\"';
4330 out[speclen] = '\0';
4331 if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4333 /* Have we been working with an expanded, but not resultant, spec? */
4334 /* Also, convert back to Unix syntax if necessary. */
4336 if (!rms_nam_rsll(mynam)) {
4338 if (do_tounixspec(esa,outbuf,0) == NULL) {
4344 else strcpy(outbuf,esa);
4347 Newx(tmpfspec, VMS_MAXRSS, char);
4348 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4354 strcpy(outbuf,tmpfspec);
4358 rms_set_rsal(mynam, NULL, 0, NULL, 0);
4359 sts = rms_free_search_context(&myfab); /* Free search context */
4366 /* External entry points */
4367 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4368 { return do_rmsexpand(spec,buf,0,def,opt); }
4369 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4370 { return do_rmsexpand(spec,buf,1,def,opt); }
4374 ** The following routines are provided to make life easier when
4375 ** converting among VMS-style and Unix-style directory specifications.
4376 ** All will take input specifications in either VMS or Unix syntax. On
4377 ** failure, all return NULL. If successful, the routines listed below
4378 ** return a pointer to a buffer containing the appropriately
4379 ** reformatted spec (and, therefore, subsequent calls to that routine
4380 ** will clobber the result), while the routines of the same names with
4381 ** a _ts suffix appended will return a pointer to a mallocd string
4382 ** containing the appropriately reformatted spec.
4383 ** In all cases, only explicit syntax is altered; no check is made that
4384 ** the resulting string is valid or that the directory in question
4387 ** fileify_dirspec() - convert a directory spec into the name of the
4388 ** directory file (i.e. what you can stat() to see if it's a dir).
4389 ** The style (VMS or Unix) of the result is the same as the style
4390 ** of the parameter passed in.
4391 ** pathify_dirspec() - convert a directory spec into a path (i.e.
4392 ** what you prepend to a filename to indicate what directory it's in).
4393 ** The style (VMS or Unix) of the result is the same as the style
4394 ** of the parameter passed in.
4395 ** tounixpath() - convert a directory spec into a Unix-style path.
4396 ** tovmspath() - convert a directory spec into a VMS-style path.
4397 ** tounixspec() - convert any file spec into a Unix-style file spec.
4398 ** tovmsspec() - convert any file spec into a VMS-style spec.
4400 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
4401 ** Permission is given to distribute this code as part of the Perl
4402 ** standard distribution under the terms of the GNU General Public
4403 ** License or the Perl Artistic License. Copies of each may be
4404 ** found in the Perl standard distribution.
4407 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4408 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4410 static char __fileify_retbuf[VMS_MAXRSS];
4411 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4412 char *retspec, *cp1, *cp2, *lastdir;
4413 char *trndir, *vmsdir;
4414 unsigned short int trnlnm_iter_count;
4417 if (!dir || !*dir) {
4418 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4420 dirlen = strlen(dir);
4421 while (dirlen && dir[dirlen-1] == '/') --dirlen;
4422 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4423 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4430 if (dirlen > (VMS_MAXRSS - 1)) {
4431 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4434 Newx(trndir, VMS_MAXRSS + 1, char);
4435 if (!strpbrk(dir+1,"/]>:") &&
4436 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4437 strcpy(trndir,*dir == '/' ? dir + 1: dir);
4438 trnlnm_iter_count = 0;
4439 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4440 trnlnm_iter_count++;
4441 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4443 dirlen = strlen(trndir);
4446 strncpy(trndir,dir,dirlen);
4447 trndir[dirlen] = '\0';
4450 /* At this point we are done with *dir and use *trndir which is a
4451 * copy that can be modified. *dir must not be modified.
4454 /* If we were handed a rooted logical name or spec, treat it like a
4455 * simple directory, so that
4456 * $ Define myroot dev:[dir.]
4457 * ... do_fileify_dirspec("myroot",buf,1) ...
4458 * does something useful.
4460 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4461 trndir[--dirlen] = '\0';
4462 trndir[dirlen-1] = ']';
4464 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4465 trndir[--dirlen] = '\0';
4466 trndir[dirlen-1] = '>';
4469 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4470 /* If we've got an explicit filename, we can just shuffle the string. */
4471 if (*(cp1+1)) hasfilename = 1;
4472 /* Similarly, we can just back up a level if we've got multiple levels
4473 of explicit directories in a VMS spec which ends with directories. */
4475 for (cp2 = cp1; cp2 > trndir; cp2--) {
4477 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4478 *cp2 = *cp1; *cp1 = '\0';
4483 if (*cp2 == '[' || *cp2 == '<') break;
4488 Newx(vmsdir, VMS_MAXRSS + 1, char);
4489 cp1 = strpbrk(trndir,"]:>");
4490 if (hasfilename || !cp1) { /* Unix-style path or filename */
4491 if (trndir[0] == '.') {
4492 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4495 return do_fileify_dirspec("[]",buf,ts);
4497 else if (trndir[1] == '.' &&
4498 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4501 return do_fileify_dirspec("[-]",buf,ts);
4504 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
4505 dirlen -= 1; /* to last element */
4506 lastdir = strrchr(trndir,'/');
4508 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4509 /* If we have "/." or "/..", VMSify it and let the VMS code
4510 * below expand it, rather than repeating the code to handle
4511 * relative components of a filespec here */
4513 if (*(cp1+2) == '.') cp1++;
4514 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4516 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4521 if (strchr(vmsdir,'/') != NULL) {
4522 /* If do_tovmsspec() returned it, it must have VMS syntax
4523 * delimiters in it, so it's a mixed VMS/Unix spec. We take
4524 * the time to check this here only so we avoid a recursion
4525 * loop; otherwise, gigo.
4529 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
4532 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4537 ret_chr = do_tounixspec(trndir,buf,ts);
4543 } while ((cp1 = strstr(cp1,"/.")) != NULL);
4544 lastdir = strrchr(trndir,'/');
4546 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4548 /* Ditto for specs that end in an MFD -- let the VMS code
4549 * figure out whether it's a real device or a rooted logical. */
4551 /* This should not happen any more. Allowing the fake /000000
4552 * in a UNIX pathname causes all sorts of problems when trying
4553 * to run in UNIX emulation. So the VMS to UNIX conversions
4554 * now remove the fake /000000 directories.
4557 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4558 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4563 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4568 ret_chr = do_tounixspec(trndir,buf,ts);
4575 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4576 !(lastdir = cp1 = strrchr(trndir,']')) &&
4577 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4578 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
4581 /* For EFS or ODS-5 look for the last dot */
4582 if (decc_efs_charset) {
4583 cp2 = strrchr(cp1,'.');
4585 if (vms_process_case_tolerant) {
4586 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4587 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4588 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4589 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4590 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4591 (ver || *cp3)))))) {
4595 set_vaxc_errno(RMS$_DIR);
4600 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4601 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4602 !*(cp2+3) || *(cp2+3) != 'R' ||
4603 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4604 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4605 (ver || *cp3)))))) {
4609 set_vaxc_errno(RMS$_DIR);
4613 dirlen = cp2 - trndir;
4617 retlen = dirlen + 6;
4618 if (buf) retspec = buf;
4619 else if (ts) Newx(retspec,retlen+1,char);
4620 else retspec = __fileify_retbuf;
4621 memcpy(retspec,trndir,dirlen);
4622 retspec[dirlen] = '\0';
4624 /* We've picked up everything up to the directory file name.
4625 Now just add the type and version, and we're set. */
4626 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4627 strcat(retspec,".dir;1");
4629 strcat(retspec,".DIR;1");
4634 else { /* VMS-style directory spec */
4636 char *esa, term, *cp;
4637 unsigned long int sts, cmplen, haslower = 0;
4638 unsigned int nam_fnb;
4640 struct FAB dirfab = cc$rms_fab;
4641 rms_setup_nam(savnam);
4642 rms_setup_nam(dirnam);
4644 Newx(esa, VMS_MAXRSS + 1, char);
4645 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4646 rms_bind_fab_nam(dirfab, dirnam);
4647 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4648 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4649 #ifdef NAM$M_NO_SHORT_UPCASE
4650 if (decc_efs_case_preserve)
4651 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4654 for (cp = trndir; *cp; cp++)
4655 if (islower(*cp)) { haslower = 1; break; }
4656 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4657 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4658 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4659 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4666 set_vaxc_errno(dirfab.fab$l_sts);
4672 /* Does the file really exist? */
4673 if (sys$search(&dirfab)& STS$K_SUCCESS) {
4674 /* Yes; fake the fnb bits so we'll check type below */
4675 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4677 else { /* No; just work with potential name */
4678 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4683 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
4684 sts = rms_free_search_context(&dirfab);
4689 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4690 cp1 = strchr(esa,']');
4691 if (!cp1) cp1 = strchr(esa,'>');
4692 if (cp1) { /* Should always be true */
4693 rms_nam_esll(dirnam) -= cp1 - esa - 1;
4694 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
4697 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
4698 /* Yep; check version while we're at it, if it's there. */
4699 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
4700 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
4701 /* Something other than .DIR[;1]. Bzzt. */
4702 sts = rms_free_search_context(&dirfab);
4707 set_vaxc_errno(RMS$_DIR);
4711 esa[rms_nam_esll(dirnam)] = '\0';
4712 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
4713 /* They provided at least the name; we added the type, if necessary, */
4714 if (buf) retspec = buf; /* in sys$parse() */
4715 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
4716 else retspec = __fileify_retbuf;
4717 strcpy(retspec,esa);
4718 sts = rms_free_search_context(&dirfab);
4724 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4725 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4727 rms_nam_esll(dirnam) -= 9;
4729 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4730 if (cp1 == NULL) { /* should never happen */
4731 sts = rms_free_search_context(&dirfab);
4739 retlen = strlen(esa);
4740 cp1 = strrchr(esa,'.');
4741 /* ODS-5 directory specifications can have extra "." in them. */
4742 while (cp1 != NULL) {
4743 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4747 while ((cp1 > esa) && (*cp1 != '.'))
4754 if ((cp1) != NULL) {
4755 /* There's more than one directory in the path. Just roll back. */
4757 if (buf) retspec = buf;
4758 else if (ts) Newx(retspec,retlen+7,char);
4759 else retspec = __fileify_retbuf;
4760 strcpy(retspec,esa);
4763 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
4764 /* Go back and expand rooted logical name */
4765 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
4766 #ifdef NAM$M_NO_SHORT_UPCASE
4767 if (decc_efs_case_preserve)
4768 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4770 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
4771 sts = rms_free_search_context(&dirfab);
4776 set_vaxc_errno(dirfab.fab$l_sts);
4779 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
4780 if (buf) retspec = buf;
4781 else if (ts) Newx(retspec,retlen+16,char);
4782 else retspec = __fileify_retbuf;
4783 cp1 = strstr(esa,"][");
4784 if (!cp1) cp1 = strstr(esa,"]<");
4786 memcpy(retspec,esa,dirlen);
4787 if (!strncmp(cp1+2,"000000]",7)) {
4788 retspec[dirlen-1] = '\0';
4789 /* Not full ODS-5, just extra dots in directories for now */
4790 cp1 = retspec + dirlen - 1;
4791 while (cp1 > retspec)
4796 if (*(cp1-1) != '^')
4801 if (*cp1 == '.') *cp1 = ']';
4803 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4804 memmove(cp1+1,"000000]",7);
4808 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
4809 retspec[retlen] = '\0';
4810 /* Convert last '.' to ']' */
4811 cp1 = retspec+retlen-1;
4812 while (*cp != '[') {
4815 /* Do not trip on extra dots in ODS-5 directories */
4816 if ((cp1 == retspec) || (*(cp1-1) != '^'))
4820 if (*cp1 == '.') *cp1 = ']';
4822 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4823 memmove(cp1+1,"000000]",7);
4827 else { /* This is a top-level dir. Add the MFD to the path. */
4828 if (buf) retspec = buf;
4829 else if (ts) Newx(retspec,retlen+16,char);
4830 else retspec = __fileify_retbuf;
4833 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
4834 strcpy(cp2,":[000000]");
4839 sts = rms_free_search_context(&dirfab);
4840 /* We've set up the string up through the filename. Add the
4841 type and version, and we're done. */
4842 strcat(retspec,".DIR;1");
4844 /* $PARSE may have upcased filespec, so convert output to lower
4845 * case if input contained any lowercase characters. */
4846 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
4852 } /* end of do_fileify_dirspec() */
4854 /* External entry points */
4855 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
4856 { return do_fileify_dirspec(dir,buf,0); }
4857 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
4858 { return do_fileify_dirspec(dir,buf,1); }
4860 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
4861 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
4863 static char __pathify_retbuf[VMS_MAXRSS];
4864 unsigned long int retlen;
4865 char *retpath, *cp1, *cp2, *trndir;
4866 unsigned short int trnlnm_iter_count;
4870 if (!dir || !*dir) {
4871 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4874 Newx(trndir, VMS_MAXRSS, char);
4875 if (*dir) strcpy(trndir,dir);
4876 else getcwd(trndir,VMS_MAXRSS - 1);
4878 trnlnm_iter_count = 0;
4879 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
4880 && my_trnlnm(trndir,trndir,0)) {
4881 trnlnm_iter_count++;
4882 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4883 trnlen = strlen(trndir);
4885 /* Trap simple rooted lnms, and return lnm:[000000] */
4886 if (!strcmp(trndir+trnlen-2,".]")) {
4887 if (buf) retpath = buf;
4888 else if (ts) Newx(retpath,strlen(dir)+10,char);
4889 else retpath = __pathify_retbuf;
4890 strcpy(retpath,dir);
4891 strcat(retpath,":[000000]");
4897 /* At this point we do not work with *dir, but the copy in
4898 * *trndir that is modifiable.
4901 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
4902 if (*trndir == '.' && (*(trndir+1) == '\0' ||
4903 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
4904 retlen = 2 + (*(trndir+1) != '\0');
4906 if ( !(cp1 = strrchr(trndir,'/')) &&
4907 !(cp1 = strrchr(trndir,']')) &&
4908 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
4909 if ((cp2 = strchr(cp1,'.')) != NULL &&
4910 (*(cp2-1) != '/' || /* Trailing '.', '..', */
4911 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
4912 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
4913 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
4916 /* For EFS or ODS-5 look for the last dot */
4917 if (decc_efs_charset) {
4918 cp2 = strrchr(cp1,'.');
4920 if (vms_process_case_tolerant) {
4921 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4922 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4923 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4924 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4925 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4926 (ver || *cp3)))))) {
4929 set_vaxc_errno(RMS$_DIR);
4934 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4935 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4936 !*(cp2+3) || *(cp2+3) != 'R' ||
4937 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4938 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4939 (ver || *cp3)))))) {
4942 set_vaxc_errno(RMS$_DIR);
4946 retlen = cp2 - trndir + 1;
4948 else { /* No file type present. Treat the filename as a directory. */
4949 retlen = strlen(trndir) + 1;
4952 if (buf) retpath = buf;
4953 else if (ts) Newx(retpath,retlen+1,char);
4954 else retpath = __pathify_retbuf;
4955 strncpy(retpath, trndir, retlen-1);
4956 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
4957 retpath[retlen-1] = '/'; /* with '/', add it. */
4958 retpath[retlen] = '\0';
4960 else retpath[retlen-1] = '\0';
4962 else { /* VMS-style directory spec */
4964 unsigned long int sts, cmplen, haslower;
4965 struct FAB dirfab = cc$rms_fab;
4967 rms_setup_nam(savnam);
4968 rms_setup_nam(dirnam);
4970 /* If we've got an explicit filename, we can just shuffle the string. */
4971 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
4972 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
4973 if ((cp2 = strchr(cp1,'.')) != NULL) {
4975 if (vms_process_case_tolerant) {
4976 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4977 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4978 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4979 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4980 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4981 (ver || *cp3)))))) {
4984 set_vaxc_errno(RMS$_DIR);
4989 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4990 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4991 !*(cp2+3) || *(cp2+3) != 'R' ||
4992 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4993 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4994 (ver || *cp3)))))) {
4997 set_vaxc_errno(RMS$_DIR);
5002 else { /* No file type, so just draw name into directory part */
5003 for (cp2 = cp1; *cp2; cp2++) ;
5006 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5008 /* We've now got a VMS 'path'; fall through */
5011 dirlen = strlen(trndir);
5012 if (trndir[dirlen-1] == ']' ||
5013 trndir[dirlen-1] == '>' ||
5014 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5015 if (buf) retpath = buf;
5016 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5017 else retpath = __pathify_retbuf;
5018 strcpy(retpath,trndir);
5022 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5023 Newx(esa, VMS_MAXRSS, char);
5024 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5025 rms_bind_fab_nam(dirfab, dirnam);
5026 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5027 #ifdef NAM$M_NO_SHORT_UPCASE
5028 if (decc_efs_case_preserve)
5029 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5032 for (cp = trndir; *cp; cp++)
5033 if (islower(*cp)) { haslower = 1; break; }
5035 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5036 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5037 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5038 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5044 set_vaxc_errno(dirfab.fab$l_sts);
5050 /* Does the file really exist? */
5051 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5052 if (dirfab.fab$l_sts != RMS$_FNF) {
5054 sts1 = rms_free_search_context(&dirfab);
5058 set_vaxc_errno(dirfab.fab$l_sts);
5061 dirnam = savnam; /* No; just work with potential name */
5064 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5065 /* Yep; check version while we're at it, if it's there. */
5066 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5067 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5069 /* Something other than .DIR[;1]. Bzzt. */
5070 sts2 = rms_free_search_context(&dirfab);
5074 set_vaxc_errno(RMS$_DIR);
5078 /* OK, the type was fine. Now pull any file name into the
5080 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5082 cp1 = strrchr(esa,'>');
5083 *(rms_nam_typel(dirnam)) = '>';
5086 *(rms_nam_typel(dirnam) + 1) = '\0';
5087 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5088 if (buf) retpath = buf;
5089 else if (ts) Newx(retpath,retlen,char);
5090 else retpath = __pathify_retbuf;
5091 strcpy(retpath,esa);
5093 sts = rms_free_search_context(&dirfab);
5094 /* $PARSE may have upcased filespec, so convert output to lower
5095 * case if input contained any lowercase characters. */
5096 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5101 } /* end of do_pathify_dirspec() */
5103 /* External entry points */
5104 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5105 { return do_pathify_dirspec(dir,buf,0); }
5106 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5107 { return do_pathify_dirspec(dir,buf,1); }
5109 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5110 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5112 static char __tounixspec_retbuf[VMS_MAXRSS];
5113 char *dirend, *rslt, *cp1, *cp3, tmp[VMS_MAXRSS];
5115 int devlen, dirlen, retlen = VMS_MAXRSS;
5116 int expand = 1; /* guarantee room for leading and trailing slashes */
5117 unsigned short int trnlnm_iter_count;
5120 if (spec == NULL) return NULL;
5121 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
5122 if (buf) rslt = buf;
5124 retlen = strlen(spec);
5125 cp1 = strchr(spec,'[');
5126 if (!cp1) cp1 = strchr(spec,'<');
5128 for (cp1++; *cp1; cp1++) {
5129 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
5130 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
5131 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
5134 Newx(rslt,retlen+2+2*expand,char);
5136 else rslt = __tounixspec_retbuf;
5138 /* New VMS specific format needs translation
5139 * glob passes filenames with trailing '\n' and expects this preserved.
5141 if (decc_posix_compliant_pathnames) {
5142 if (strncmp(spec, "\"^UP^", 5) == 0) {
5148 Newx(tunix, VMS_MAXRSS + 1,char);
5149 strcpy(tunix, spec);
5150 tunix_len = strlen(tunix);
5152 if (tunix[tunix_len - 1] == '\n') {
5153 tunix[tunix_len - 1] = '\"';
5154 tunix[tunix_len] = '\0';
5158 uspec = decc$translate_vms(tunix);
5160 if ((int)uspec > 0) {
5166 /* If we can not translate it, makemaker wants as-is */
5174 cmp_rslt = 0; /* Presume VMS */
5175 cp1 = strchr(spec, '/');
5179 /* Look for EFS ^/ */
5180 if (decc_efs_charset) {
5181 while (cp1 != NULL) {
5184 /* Found illegal VMS, assume UNIX */
5189 cp1 = strchr(cp1, '/');
5193 /* Look for "." and ".." */
5194 if (decc_filename_unix_report) {
5195 if (spec[0] == '.') {
5196 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5200 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5206 /* This is already UNIX or at least nothing VMS understands */
5214 dirend = strrchr(spec,']');
5215 if (dirend == NULL) dirend = strrchr(spec,'>');
5216 if (dirend == NULL) dirend = strchr(spec,':');
5217 if (dirend == NULL) {
5222 /* Special case 1 - sys$posix_root = / */
5223 #if __CRTL_VER >= 70000000
5224 if (!decc_disable_posix_root) {
5225 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5233 /* Special case 2 - Convert NLA0: to /dev/null */
5234 #if __CRTL_VER < 70000000
5235 cmp_rslt = strncmp(spec,"NLA0:", 5);
5237 cmp_rslt = strncmp(spec,"nla0:", 5);
5239 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5241 if (cmp_rslt == 0) {
5242 strcpy(rslt, "/dev/null");
5245 if (spec[6] != '\0') {
5252 /* Also handle special case "SYS$SCRATCH:" */
5253 #if __CRTL_VER < 70000000
5254 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5256 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5258 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5260 if (cmp_rslt == 0) {
5263 islnm = my_trnlnm(tmp, "TMP", 0);
5265 strcpy(rslt, "/tmp");
5268 if (spec[12] != '\0') {
5276 if (*cp2 != '[' && *cp2 != '<') {
5279 else { /* the VMS spec begins with directories */
5281 if (*cp2 == ']' || *cp2 == '>') {
5282 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5285 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5286 if (getcwd(tmp,sizeof tmp,1) == NULL) {
5287 if (ts) Safefree(rslt);
5290 trnlnm_iter_count = 0;
5293 while (*cp3 != ':' && *cp3) cp3++;
5295 if (strchr(cp3,']') != NULL) break;
5296 trnlnm_iter_count++;
5297 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5298 } while (vmstrnenv(tmp,tmp,0,fildev,0));
5300 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5301 retlen = devlen + dirlen;
5302 Renew(rslt,retlen+1+2*expand,char);
5308 *(cp1++) = *(cp3++);
5309 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
5313 if ((*cp2 == '^')) {
5314 /* EFS file escape, pass the next character as is */
5315 /* Fix me: HEX encoding for UNICODE not implemented */
5318 else if ( *cp2 == '.') {
5319 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5320 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5326 for (; cp2 <= dirend; cp2++) {
5327 if ((*cp2 == '^')) {
5328 /* EFS file escape, pass the next character as is */
5329 /* Fix me: HEX encoding for UNICODE not implemented */
5335 if (*(cp2+1) == '[') cp2++;
5337 else if (*cp2 == ']' || *cp2 == '>') {
5338 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5340 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5342 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5343 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5344 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5345 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5346 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5348 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5349 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5353 else if (*cp2 == '-') {
5354 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5355 while (*cp2 == '-') {
5357 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5359 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5360 if (ts) Safefree(rslt); /* filespecs like */
5361 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
5365 else *(cp1++) = *cp2;
5367 else *(cp1++) = *cp2;
5369 while (*cp2) *(cp1++) = *(cp2++);
5372 /* This still leaves /000000/ when working with a
5373 * VMS device root or concealed root.
5379 ulen = strlen(rslt);
5381 /* Get rid of "000000/ in rooted filespecs */
5383 zeros = strstr(rslt, "/000000/");
5384 if (zeros != NULL) {
5386 mlen = ulen - (zeros - rslt) - 7;
5387 memmove(zeros, &zeros[7], mlen);
5396 } /* end of do_tounixspec() */
5398 /* External entry points */
5399 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5400 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5402 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5404 static int posix_to_vmsspec
5405 (char *vmspath, int vmspath_len, const char *unixpath) {
5407 struct FAB myfab = cc$rms_fab;
5408 struct NAML mynam = cc$rms_naml;
5409 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5410 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5416 /* If not a posix spec already, convert it */
5418 unixlen = strlen(unixpath);
5423 if (strncmp(unixpath,"\"^UP^",5) != 0) {
5424 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5427 /* This is already a VMS specification, no conversion */
5429 strncpy(vmspath,unixpath, vmspath_len);
5431 vmspath[vmspath_len] = 0;
5432 if (unixpath[unixlen - 1] == '/')
5434 Newx(esa, VMS_MAXRSS, char);
5435 myfab.fab$l_fna = vmspath;
5436 myfab.fab$b_fns = strlen(vmspath);
5437 myfab.fab$l_naml = &mynam;
5438 mynam.naml$l_esa = NULL;
5439 mynam.naml$b_ess = 0;
5440 mynam.naml$l_long_expand = esa;
5441 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5442 mynam.naml$l_rsa = NULL;
5443 mynam.naml$b_rss = 0;
5444 if (decc_efs_case_preserve)
5445 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5446 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5448 /* Set up the remaining naml fields */
5449 sts = sys$parse(&myfab);
5451 /* It failed! Try again as a UNIX filespec */
5457 /* get the Device ID and the FID */
5458 sts = sys$search(&myfab);
5459 /* on any failure, returned the POSIX ^UP^ filespec */
5464 specdsc.dsc$a_pointer = vmspath;
5465 specdsc.dsc$w_length = vmspath_len;
5467 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5468 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5469 sts = lib$fid_to_name
5470 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5472 /* on any failure, returned the POSIX ^UP^ filespec */
5474 /* This can happen if user does not have permission to read directories */
5475 if (strncmp(unixpath,"\"^UP^",5) != 0)
5476 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5478 strcpy(vmspath, unixpath);
5481 vmspath[specdsc.dsc$w_length] = 0;
5483 /* Are we expecting a directory? */
5484 if (dir_flag != 0) {
5490 i = specdsc.dsc$w_length - 1;
5494 /* Version must be '1' */
5495 if (vmspath[i--] != '1')
5497 /* Version delimiter is one of ".;" */
5498 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5501 if (vmspath[i--] != 'R')
5503 if (vmspath[i--] != 'I')
5505 if (vmspath[i--] != 'D')
5507 if (vmspath[i--] != '.')
5509 eptr = &vmspath[i+1];
5511 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5512 if (vmspath[i-1] != '^') {
5520 /* Get rid of 6 imaginary zero directory filename */
5521 vmspath[i+1] = '\0';
5525 if (vmspath[i] == '0')
5539 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5540 static int posix_to_vmsspec_hardway
5541 (char *vmspath, int vmspath_len, const char *unixpath) {
5544 const char *unixptr;
5546 const char *lastslash;
5547 const char *lastdot;
5558 /* Ignore leading "/" characters */
5559 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5562 unixlen = strlen(unixptr);
5564 /* Do nothing with blank paths */
5570 lastslash = strrchr(unixptr,'/');
5571 lastdot = strrchr(unixptr,'.');
5574 /* last dot is last dot or past end of string */
5575 if (lastdot == NULL)
5576 lastdot = unixptr + unixlen;
5578 /* if no directories, set last slash to beginning of string */
5579 if (lastslash == NULL) {
5580 lastslash = unixptr;
5583 /* Watch out for trailing "." after last slash, still a directory */
5584 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5585 lastslash = unixptr + unixlen;
5588 /* Watch out for traiing ".." after last slash, still a directory */
5589 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5590 lastslash = unixptr + unixlen;
5593 /* dots in directories are aways escaped */
5594 if (lastdot < lastslash)
5595 lastdot = unixptr + unixlen;
5598 /* if (unixptr < lastslash) then we are in a directory */
5606 /* This could have a "^UP^ on the front */
5607 if (strncmp(unixptr,"\"^UP^",5) == 0) {
5612 /* Start with the UNIX path */
5613 if (*unixptr != '/') {
5614 /* relative paths */
5615 if (lastslash > unixptr) {
5618 /* skip leading ./ */
5620 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5626 /* Are we still in a directory? */
5627 if (unixptr <= lastslash) {
5632 /* if not backing up, then it is relative forward. */
5633 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5634 ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5642 /* Perl wants an empty directory here to tell the difference
5643 * between a DCL commmand and a filename
5652 /* Handle two special files . and .. */
5653 if (unixptr[0] == '.') {
5654 if (unixptr[1] == '\0') {
5661 if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5672 else { /* Absolute PATH handling */
5676 /* Need to find out where root is */
5678 /* In theory, this procedure should never get an absolute POSIX pathname
5679 * that can not be found on the POSIX root.
5680 * In practice, that can not be relied on, and things will show up
5681 * here that are a VMS device name or concealed logical name instead.
5682 * So to make things work, this procedure must be tolerant.
5684 Newx(esa, vmspath_len, char);
5687 nextslash = strchr(&unixptr[1],'/');
5689 if (nextslash != NULL) {
5690 seg_len = nextslash - &unixptr[1];
5691 strncpy(vmspath, unixptr, seg_len + 1);
5692 vmspath[seg_len+1] = 0;
5693 sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5697 /* This is verified to be a real path */
5699 sts = posix_to_vmsspec(esa, vmspath_len, "/");
5700 strcpy(vmspath, esa);
5701 vmslen = strlen(vmspath);
5702 vmsptr = vmspath + vmslen;
5704 if (unixptr < lastslash) {
5713 cmp = strcmp(rptr,"000000.");
5718 } /* removing 6 zeros */
5719 } /* vmslen < 7, no 6 zeros possible */
5720 } /* Not in a directory */
5721 } /* end of verified real path handling */
5726 /* Ok, we have a device or a concealed root that is not in POSIX
5727 * or we have garbage. Make the best of it.
5730 /* Posix to VMS destroyed this, so copy it again */
5731 strncpy(vmspath, &unixptr[1], seg_len);
5732 vmspath[seg_len] = 0;
5734 vmsptr = &vmsptr[vmslen];
5737 /* Now do we need to add the fake 6 zero directory to it? */
5739 if ((*lastslash == '/') && (nextslash < lastslash)) {
5740 /* No there is another directory */
5746 /* now we have foo:bar or foo:[000000]bar to decide from */
5747 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
5748 trnend = islnm ? islnm - 1 : 0;
5750 /* if this was a logical name, ']' or '>' must be present */
5751 /* if not a logical name, then assume a device and hope. */
5752 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
5754 /* if log name and trailing '.' then rooted - treat as device */
5755 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
5757 /* Fix me, if not a logical name, a device lookup should be
5758 * done to see if the device is file structured. If the device
5759 * is not file structured, the 6 zeros should not be put on.
5761 * As it is, perl is occasionally looking for dev:[000000]tty.
5762 * which looks a little strange.
5765 if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
5766 /* No real directory present */
5771 /* Put the device delimiter on */
5774 unixptr = nextslash;
5777 /* Start directory if needed */
5778 if (!islnm || add_6zero) {
5784 /* add fake 000000] if needed */
5797 } /* non-POSIX translation */
5799 } /* End of relative/absolute path handling */
5801 while ((*unixptr) && (vmslen < vmspath_len)){
5806 if (dir_start != 0) {
5808 /* First characters in a directory are handled special */
5809 while ((*unixptr == '/') ||
5810 ((*unixptr == '.') &&
5811 ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
5816 /* Skip redundant / in specification */
5817 while ((*unixptr == '/') && (dir_start != 0)) {
5820 if (unixptr == lastslash)
5823 if (unixptr == lastslash)
5826 /* Skip redundant ./ characters */
5827 while ((*unixptr == '.') &&
5828 ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
5831 if (unixptr == lastslash)
5833 if (*unixptr == '/')
5836 if (unixptr == lastslash)
5839 /* Skip redundant ../ characters */
5840 while ((*unixptr == '.') && (unixptr[1] == '.') &&
5841 ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
5842 /* Set the backing up flag */
5848 unixptr++; /* first . */
5849 unixptr++; /* second . */
5850 if (unixptr == lastslash)
5852 if (*unixptr == '/') /* The slash */
5855 if (unixptr == lastslash)
5858 /* To do: Perl expects /.../ to be translated to [...] on VMS */
5859 /* Not needed when VMS is pretending to be UNIX. */
5861 /* Is this loop stuck because of too many dots? */
5862 if (loop_flag == 0) {
5863 /* Exit the loop and pass the rest through */
5868 /* Are we done with directories yet? */
5869 if (unixptr >= lastslash) {
5871 /* Watch out for trailing dots */
5880 if (*unixptr == '/')
5884 /* Have we stopped backing up? */
5889 /* dir_start continues to be = 1 */
5891 if (*unixptr == '-') {
5893 *vmsptr++ = *unixptr++;
5897 /* Now are we done with directories yet? */
5898 if (unixptr >= lastslash) {
5900 /* Watch out for trailing dots */
5916 if (*unixptr == '\0')
5919 /* Normal characters - More EFS work probably needed */
5925 /* remove multiple / */
5926 while (unixptr[1] == '/') {
5929 if (unixptr == lastslash) {
5930 /* Watch out for trailing dots */
5942 /* To do: Perl expects /.../ to be translated to [...] on VMS */
5943 /* Not needed when VMS is pretending to be UNIX. */
5947 if (*unixptr != '\0')
5963 if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
5969 /* trailing dot ==> '^..' on VMS */
5970 if (*unixptr == '\0') {
5974 *vmsptr++ = *unixptr++;
5977 if (quoted && (unixptr[1] == '\0')) {
5982 *vmsptr++ = *unixptr++;
5989 *vmsptr++ = *unixptr++;
5993 if (*unixptr != '\0') {
5994 *vmsptr++ = *unixptr++;
6001 /* Make sure directory is closed */
6002 if (unixptr == lastslash) {
6004 vmsptr2 = vmsptr - 1;
6006 if (*vmsptr2 != ']') {
6009 /* directories do not end in a dot bracket */
6010 if (*vmsptr2 == '.') {
6014 if (*vmsptr2 != '^') {
6015 vmsptr--; /* back up over the dot */
6023 /* Add a trailing dot if a file with no extension */
6024 vmsptr2 = vmsptr - 1;
6025 if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6026 (*lastdot != '.')) {
6037 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6038 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6039 static char __tovmsspec_retbuf[VMS_MAXRSS];
6040 char *rslt, *dirend;
6045 unsigned long int infront = 0, hasdir = 1;
6049 if (path == NULL) return NULL;
6050 rslt_len = VMS_MAXRSS;
6051 if (buf) rslt = buf;
6052 else if (ts) Newx(rslt, VMS_MAXRSS, char);
6053 else rslt = __tovmsspec_retbuf;
6054 if (strpbrk(path,"]:>") ||
6055 (dirend = strrchr(path,'/')) == NULL) {
6056 if (path[0] == '.') {
6057 if (path[1] == '\0') strcpy(rslt,"[]");
6058 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6059 else strcpy(rslt,path); /* probably garbage */
6061 else strcpy(rslt,path);
6065 /* Posix specifications are now a native VMS format */
6066 /*--------------------------------------------------*/
6067 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6068 if (decc_posix_compliant_pathnames) {
6069 if (strncmp(path,"\"^UP^",5) == 0) {
6070 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6076 vms_delim = strpbrk(path,"]:>");
6078 if ((vms_delim != NULL) ||
6079 ((dirend = strrchr(path,'/')) == NULL)) {
6081 /* VMS special characters found! */
6083 if (path[0] == '.') {
6084 if (path[1] == '\0') strcpy(rslt,"[]");
6085 else if (path[1] == '.' && path[2] == '\0')
6088 /* Dot preceeding a device or directory ? */
6090 /* If not in POSIX mode, pass it through and hope it works */
6091 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6092 if (!decc_posix_compliant_pathnames)
6093 strcpy(rslt,path); /* probably garbage */
6095 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6097 strcpy(rslt,path); /* probably garbage */
6103 /* If no VMS characters and in POSIX mode, convert it!
6104 * This is the easiest way to get directory specifications
6105 * handled correctly in POSIX mode
6107 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6108 if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6109 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6111 /* No unix path separators - presume VMS already */
6115 strcpy(rslt,path); /* probably garbage */
6121 /* If POSIX mode active, handle the conversion */
6122 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6123 if (decc_posix_compliant_pathnames) {
6124 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6129 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
6130 if (!*(dirend+2)) dirend +=2;
6131 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6132 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6137 lastdot = strrchr(cp2,'.');
6143 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
6145 if (decc_disable_posix_root) {
6146 strcpy(rslt,"sys$disk:[000000]");
6149 strcpy(rslt,"sys$posix_root:[000000]");
6153 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6155 Newx(trndev, VMS_MAXRSS, char);
6156 islnm = my_trnlnm(rslt,trndev,0);
6158 /* DECC special handling */
6160 if (strcmp(rslt,"bin") == 0) {
6161 strcpy(rslt,"sys$system");
6164 islnm = my_trnlnm(rslt,trndev,0);
6166 else if (strcmp(rslt,"tmp") == 0) {
6167 strcpy(rslt,"sys$scratch");
6170 islnm = my_trnlnm(rslt,trndev,0);
6172 else if (!decc_disable_posix_root) {
6173 strcpy(rslt, "sys$posix_root");
6177 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
6178 islnm = my_trnlnm(rslt,trndev,0);
6180 else if (strcmp(rslt,"dev") == 0) {
6181 if (strncmp(cp2,"/null", 5) == 0) {
6182 if ((cp2[5] == 0) || (cp2[5] == '/')) {
6183 strcpy(rslt,"NLA0");
6187 islnm = my_trnlnm(rslt,trndev,0);
6193 trnend = islnm ? strlen(trndev) - 1 : 0;
6194 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6195 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6196 /* If the first element of the path is a logical name, determine
6197 * whether it has to be translated so we can add more directories. */
6198 if (!islnm || rooted) {
6201 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6205 if (cp2 != dirend) {
6206 strcpy(rslt,trndev);
6207 cp1 = rslt + trnend;
6214 if (decc_disable_posix_root) {
6225 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6226 cp2 += 2; /* skip over "./" - it's redundant */
6227 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
6229 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6230 *(cp1++) = '-'; /* "../" --> "-" */
6233 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6234 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6235 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6236 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6239 else if ((cp2 != lastdot) || (lastdot < dirend)) {
6240 /* Escape the extra dots in EFS file specifications */
6243 if (cp2 > dirend) cp2 = dirend;
6245 else *(cp1++) = '.';
6247 for (; cp2 < dirend; cp2++) {
6249 if (*(cp2-1) == '/') continue;
6250 if (*(cp1-1) != '.') *(cp1++) = '.';
6253 else if (!infront && *cp2 == '.') {
6254 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6255 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
6256 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6257 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6258 else if (*(cp1-2) == '[') *(cp1-1) = '-';
6259 else { /* back up over previous directory name */
6261 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6262 if (*(cp1-1) == '[') {
6263 memcpy(cp1,"000000.",7);
6268 if (cp2 == dirend) break;
6270 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6271 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6272 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6273 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6275 *(cp1++) = '.'; /* Simulate trailing '/' */
6276 cp2 += 2; /* for loop will incr this to == dirend */
6278 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
6281 if (decc_efs_charset == 0)
6282 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
6284 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
6290 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
6292 if (decc_efs_charset == 0)
6299 else *(cp1++) = *cp2;
6303 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6304 if (hasdir) *(cp1++) = ']';
6305 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
6306 /* fixme for ODS5 */
6321 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6322 decc_readdir_dropdotnotype) {
6327 /* trailing dot ==> '^..' on VMS */
6334 *(cp1++) = *(cp2++);
6362 *(cp1++) = *(cp2++);
6365 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6366 * which is wrong. UNIX notation should be ".dir. unless
6367 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6368 * changing this behavior could break more things at this time.
6369 * efs character set effectively does not allow "." to be a version
6370 * delimiter as a further complication about changing this.
6372 if (decc_filename_unix_report != 0) {
6375 *(cp1++) = *(cp2++);
6378 *(cp1++) = *(cp2++);
6381 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6385 /* Fix me for "^]", but that requires making sure that you do
6386 * not back up past the start of the filename
6388 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6395 } /* end of do_tovmsspec() */
6397 /* External entry points */
6398 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6399 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6401 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6402 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6403 static char __tovmspath_retbuf[VMS_MAXRSS];
6405 char *pathified, *vmsified, *cp;
6407 if (path == NULL) return NULL;
6408 Newx(pathified, VMS_MAXRSS, char);
6409 if (do_pathify_dirspec(path,pathified,0) == NULL) {
6410 Safefree(pathified);
6413 Newx(vmsified, VMS_MAXRSS, char);
6414 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) {
6415 Safefree(pathified);
6419 Safefree(pathified);
6425 vmslen = strlen(vmsified);
6426 Newx(cp,vmslen+1,char);
6427 memcpy(cp,vmsified,vmslen);
6433 strcpy(__tovmspath_retbuf,vmsified);
6435 return __tovmspath_retbuf;
6438 } /* end of do_tovmspath() */
6440 /* External entry points */
6441 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6442 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6445 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6446 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6447 static char __tounixpath_retbuf[VMS_MAXRSS];
6449 char *pathified, *unixified, *cp;
6451 if (path == NULL) return NULL;
6452 Newx(pathified, VMS_MAXRSS, char);
6453 if (do_pathify_dirspec(path,pathified,0) == NULL) {
6454 Safefree(pathified);
6457 Newx(unixified, VMS_MAXRSS, char);
6458 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6459 Safefree(pathified);
6460 Safefree(unixified);
6463 Safefree(pathified);
6465 Safefree(unixified);
6469 unixlen = strlen(unixified);
6470 Newx(cp,unixlen+1,char);
6471 memcpy(cp,unixified,unixlen);
6473 Safefree(unixified);
6477 strcpy(__tounixpath_retbuf,unixified);
6478 Safefree(unixified);
6479 return __tounixpath_retbuf;
6482 } /* end of do_tounixpath() */
6484 /* External entry points */
6485 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6486 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6489 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
6491 *****************************************************************************
6493 * Copyright (C) 1989-1994 by *
6494 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
6496 * Permission is hereby granted for the reproduction of this software, *
6497 * on condition that this copyright notice is included in the reproduction, *
6498 * and that such reproduction is not for purposes of profit or material *
6501 * 27-Aug-1994 Modified for inclusion in perl5 *
6502 * by Charles Bailey bailey@newman.upenn.edu *
6503 *****************************************************************************
6507 * getredirection() is intended to aid in porting C programs
6508 * to VMS (Vax-11 C). The native VMS environment does not support
6509 * '>' and '<' I/O redirection, or command line wild card expansion,
6510 * or a command line pipe mechanism using the '|' AND background
6511 * command execution '&'. All of these capabilities are provided to any
6512 * C program which calls this procedure as the first thing in the
6514 * The piping mechanism will probably work with almost any 'filter' type
6515 * of program. With suitable modification, it may useful for other
6516 * portability problems as well.
6518 * Author: Mark Pizzolato mark@infocomm.com
6522 struct list_item *next;
6526 static void add_item(struct list_item **head,
6527 struct list_item **tail,
6531 static void mp_expand_wild_cards(pTHX_ char *item,
6532 struct list_item **head,
6533 struct list_item **tail,
6536 static int background_process(pTHX_ int argc, char **argv);
6538 static void pipe_and_fork(pTHX_ char **cmargv);
6540 /*{{{ void getredirection(int *ac, char ***av)*/
6542 mp_getredirection(pTHX_ int *ac, char ***av)
6544 * Process vms redirection arg's. Exit if any error is seen.
6545 * If getredirection() processes an argument, it is erased
6546 * from the vector. getredirection() returns a new argc and argv value.
6547 * In the event that a background command is requested (by a trailing "&"),
6548 * this routine creates a background subprocess, and simply exits the program.
6550 * Warning: do not try to simplify the code for vms. The code
6551 * presupposes that getredirection() is called before any data is
6552 * read from stdin or written to stdout.
6554 * Normal usage is as follows:
6560 * getredirection(&argc, &argv);
6564 int argc = *ac; /* Argument Count */
6565 char **argv = *av; /* Argument Vector */
6566 char *ap; /* Argument pointer */
6567 int j; /* argv[] index */
6568 int item_count = 0; /* Count of Items in List */
6569 struct list_item *list_head = 0; /* First Item in List */
6570 struct list_item *list_tail; /* Last Item in List */
6571 char *in = NULL; /* Input File Name */
6572 char *out = NULL; /* Output File Name */
6573 char *outmode = "w"; /* Mode to Open Output File */
6574 char *err = NULL; /* Error File Name */
6575 char *errmode = "w"; /* Mode to Open Error File */
6576 int cmargc = 0; /* Piped Command Arg Count */
6577 char **cmargv = NULL;/* Piped Command Arg Vector */
6580 * First handle the case where the last thing on the line ends with
6581 * a '&'. This indicates the desire for the command to be run in a
6582 * subprocess, so we satisfy that desire.
6585 if (0 == strcmp("&", ap))
6586 exit(background_process(aTHX_ --argc, argv));
6587 if (*ap && '&' == ap[strlen(ap)-1])
6589 ap[strlen(ap)-1] = '\0';
6590 exit(background_process(aTHX_ argc, argv));
6593 * Now we handle the general redirection cases that involve '>', '>>',
6594 * '<', and pipes '|'.
6596 for (j = 0; j < argc; ++j)
6598 if (0 == strcmp("<", argv[j]))
6602 fprintf(stderr,"No input file after < on command line");
6603 exit(LIB$_WRONUMARG);
6608 if ('<' == *(ap = argv[j]))
6613 if (0 == strcmp(">", ap))
6617 fprintf(stderr,"No output file after > on command line");
6618 exit(LIB$_WRONUMARG);
6637 fprintf(stderr,"No output file after > or >> on command line");
6638 exit(LIB$_WRONUMARG);
6642 if (('2' == *ap) && ('>' == ap[1]))
6659 fprintf(stderr,"No output file after 2> or 2>> on command line");
6660 exit(LIB$_WRONUMARG);
6664 if (0 == strcmp("|", argv[j]))
6668 fprintf(stderr,"No command into which to pipe on command line");
6669 exit(LIB$_WRONUMARG);
6671 cmargc = argc-(j+1);
6672 cmargv = &argv[j+1];
6676 if ('|' == *(ap = argv[j]))
6684 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6687 * Allocate and fill in the new argument vector, Some Unix's terminate
6688 * the list with an extra null pointer.
6690 Newx(argv, item_count+1, char *);
6691 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
6693 for (j = 0; j < item_count; ++j, list_head = list_head->next)
6694 argv[j] = list_head->value;
6700 fprintf(stderr,"'|' and '>' may not both be specified on command line");
6701 exit(LIB$_INVARGORD);
6703 pipe_and_fork(aTHX_ cmargv);
6706 /* Check for input from a pipe (mailbox) */
6708 if (in == NULL && 1 == isapipe(0))
6710 char mbxname[L_tmpnam];
6712 long int dvi_item = DVI$_DEVBUFSIZ;
6713 $DESCRIPTOR(mbxnam, "");
6714 $DESCRIPTOR(mbxdevnam, "");
6716 /* Input from a pipe, reopen it in binary mode to disable */
6717 /* carriage control processing. */
6719 fgetname(stdin, mbxname);
6720 mbxnam.dsc$a_pointer = mbxname;
6721 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6722 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6723 mbxdevnam.dsc$a_pointer = mbxname;
6724 mbxdevnam.dsc$w_length = sizeof(mbxname);
6725 dvi_item = DVI$_DEVNAM;
6726 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6727 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
6730 freopen(mbxname, "rb", stdin);
6733 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
6737 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6739 fprintf(stderr,"Can't open input file %s as stdin",in);
6742 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
6744 fprintf(stderr,"Can't open output file %s as stdout",out);
6747 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
6750 if (strcmp(err,"&1") == 0) {
6751 dup2(fileno(stdout), fileno(stderr));
6752 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
6755 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
6757 fprintf(stderr,"Can't open error file %s as stderr",err);
6761 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
6765 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
6768 #ifdef ARGPROC_DEBUG
6769 PerlIO_printf(Perl_debug_log, "Arglist:\n");
6770 for (j = 0; j < *ac; ++j)
6771 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
6773 /* Clear errors we may have hit expanding wildcards, so they don't
6774 show up in Perl's $! later */
6775 set_errno(0); set_vaxc_errno(1);
6776 } /* end of getredirection() */
6779 static void add_item(struct list_item **head,
6780 struct list_item **tail,
6786 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6790 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6791 *tail = (*tail)->next;
6793 (*tail)->value = value;
6797 static void mp_expand_wild_cards(pTHX_ char *item,
6798 struct list_item **head,
6799 struct list_item **tail,
6803 unsigned long int context = 0;
6811 $DESCRIPTOR(filespec, "");
6812 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
6813 $DESCRIPTOR(resultspec, "");
6814 unsigned long int lff_flags = 0;
6817 #ifdef VMS_LONGNAME_SUPPORT
6818 lff_flags = LIB$M_FIL_LONG_NAMES;
6821 for (cp = item; *cp; cp++) {
6822 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
6823 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
6825 if (!*cp || isspace(*cp))
6827 add_item(head, tail, item, count);
6832 /* "double quoted" wild card expressions pass as is */
6833 /* From DCL that means using e.g.: */
6834 /* perl program """perl.*""" */
6835 item_len = strlen(item);
6836 if ( '"' == *item && '"' == item[item_len-1] )
6839 item[item_len-2] = '\0';
6840 add_item(head, tail, item, count);
6844 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
6845 resultspec.dsc$b_class = DSC$K_CLASS_D;
6846 resultspec.dsc$a_pointer = NULL;
6847 Newx(vmsspec, VMS_MAXRSS, char);
6848 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
6849 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
6850 if (!isunix || !filespec.dsc$a_pointer)
6851 filespec.dsc$a_pointer = item;
6852 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
6854 * Only return version specs, if the caller specified a version
6856 had_version = strchr(item, ';');
6858 * Only return device and directory specs, if the caller specifed either.
6860 had_device = strchr(item, ':');
6861 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
6863 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
6864 (&filespec, &resultspec, &context,
6865 &defaultspec, 0, 0, &lff_flags)))
6870 Newx(string,resultspec.dsc$w_length+1,char);
6871 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
6872 string[resultspec.dsc$w_length] = '\0';
6873 if (NULL == had_version)
6874 *(strrchr(string, ';')) = '\0';
6875 if ((!had_directory) && (had_device == NULL))
6877 if (NULL == (devdir = strrchr(string, ']')))
6878 devdir = strrchr(string, '>');
6879 strcpy(string, devdir + 1);
6882 * Be consistent with what the C RTL has already done to the rest of
6883 * the argv items and lowercase all of these names.
6885 if (!decc_efs_case_preserve) {
6886 for (c = string; *c; ++c)
6890 if (isunix) trim_unixpath(string,item,1);
6891 add_item(head, tail, string, count);
6895 if (sts != RMS$_NMF)
6897 set_vaxc_errno(sts);
6900 case RMS$_FNF: case RMS$_DNF:
6901 set_errno(ENOENT); break;
6903 set_errno(ENOTDIR); break;
6905 set_errno(ENODEV); break;
6906 case RMS$_FNM: case RMS$_SYN:
6907 set_errno(EINVAL); break;
6909 set_errno(EACCES); break;
6911 _ckvmssts_noperl(sts);
6915 add_item(head, tail, item, count);
6916 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
6917 _ckvmssts_noperl(lib$find_file_end(&context));
6920 static int child_st[2];/* Event Flag set when child process completes */
6922 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
6924 static unsigned long int exit_handler(int *status)
6928 if (0 == child_st[0])
6930 #ifdef ARGPROC_DEBUG
6931 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
6933 fflush(stdout); /* Have to flush pipe for binary data to */
6934 /* terminate properly -- <tp@mccall.com> */
6935 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
6936 sys$dassgn(child_chan);
6938 sys$synch(0, child_st);
6943 static void sig_child(int chan)
6945 #ifdef ARGPROC_DEBUG
6946 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
6948 if (child_st[0] == 0)
6952 static struct exit_control_block exit_block =
6957 &exit_block.exit_status,
6962 pipe_and_fork(pTHX_ char **cmargv)
6965 struct dsc$descriptor_s *vmscmd;
6966 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
6967 int sts, j, l, ismcr, quote, tquote = 0;
6969 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
6970 vms_execfree(vmscmd);
6975 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
6976 && toupper(*(q+2)) == 'R' && !*(q+3);
6978 while (q && l < MAX_DCL_LINE_LENGTH) {
6980 if (j > 0 && quote) {
6986 if (ismcr && j > 1) quote = 1;
6987 tquote = (strchr(q,' ')) != NULL || *q == '\0';
6990 if (quote || tquote) {
6996 if ((quote||tquote) && *q == '"') {
7006 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7008 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7012 static int background_process(pTHX_ int argc, char **argv)
7014 char command[MAX_DCL_SYMBOL + 1] = "$";
7015 $DESCRIPTOR(value, "");
7016 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7017 static $DESCRIPTOR(null, "NLA0:");
7018 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7020 $DESCRIPTOR(pidstr, "");
7022 unsigned long int flags = 17, one = 1, retsts;
7025 strcat(command, argv[0]);
7026 len = strlen(command);
7027 while (--argc && (len < MAX_DCL_SYMBOL))
7029 strcat(command, " \"");
7030 strcat(command, *(++argv));
7031 strcat(command, "\"");
7032 len = strlen(command);
7034 value.dsc$a_pointer = command;
7035 value.dsc$w_length = strlen(value.dsc$a_pointer);
7036 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7037 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7038 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7039 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7042 _ckvmssts_noperl(retsts);
7044 #ifdef ARGPROC_DEBUG
7045 PerlIO_printf(Perl_debug_log, "%s\n", command);
7047 sprintf(pidstring, "%08X", pid);
7048 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7049 pidstr.dsc$a_pointer = pidstring;
7050 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7051 lib$set_symbol(&pidsymbol, &pidstr);
7055 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7058 /* OS-specific initialization at image activation (not thread startup) */
7059 /* Older VAXC header files lack these constants */
7060 #ifndef JPI$_RIGHTS_SIZE
7061 # define JPI$_RIGHTS_SIZE 817
7063 #ifndef KGB$M_SUBSYSTEM
7064 # define KGB$M_SUBSYSTEM 0x8
7067 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7069 /*{{{void vms_image_init(int *, char ***)*/
7071 vms_image_init(int *argcp, char ***argvp)
7073 char eqv[LNM$C_NAMLENGTH+1] = "";
7074 unsigned int len, tabct = 8, tabidx = 0;
7075 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7076 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7077 unsigned short int dummy, rlen;
7078 struct dsc$descriptor_s **tabvec;
7079 #if defined(PERL_IMPLICIT_CONTEXT)
7082 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
7083 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
7084 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7087 #ifdef KILL_BY_SIGPRC
7088 Perl_csighandler_init();
7091 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7092 _ckvmssts_noperl(iosb[0]);
7093 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7094 if (iprv[i]) { /* Running image installed with privs? */
7095 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
7100 /* Rights identifiers might trigger tainting as well. */
7101 if (!will_taint && (rlen || rsz)) {
7102 while (rlen < rsz) {
7103 /* We didn't get all the identifiers on the first pass. Allocate a
7104 * buffer much larger than $GETJPI wants (rsz is size in bytes that
7105 * were needed to hold all identifiers at time of last call; we'll
7106 * allocate that many unsigned long ints), and go back and get 'em.
7107 * If it gave us less than it wanted to despite ample buffer space,
7108 * something's broken. Is your system missing a system identifier?
7110 if (rsz <= jpilist[1].buflen) {
7111 /* Perl_croak accvios when used this early in startup. */
7112 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7113 rsz, (unsigned long) jpilist[1].buflen,
7114 "Check your rights database for corruption.\n");
7117 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7118 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7119 jpilist[1].buflen = rsz * sizeof(unsigned long int);
7120 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7121 _ckvmssts_noperl(iosb[0]);
7123 mask = jpilist[1].bufadr;
7124 /* Check attribute flags for each identifier (2nd longword); protected
7125 * subsystem identifiers trigger tainting.
7127 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7128 if (mask[i] & KGB$M_SUBSYSTEM) {
7133 if (mask != rlst) Safefree(mask);
7136 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7137 * logical, some versions of the CRTL will add a phanthom /000000/
7138 * directory. This needs to be removed.
7140 if (decc_filename_unix_report) {
7143 ulen = strlen(argvp[0][0]);
7145 zeros = strstr(argvp[0][0], "/000000/");
7146 if (zeros != NULL) {
7148 mlen = ulen - (zeros - argvp[0][0]) - 7;
7149 memmove(zeros, &zeros[7], mlen);
7151 argvp[0][0][ulen] = '\0';
7154 /* It also may have a trailing dot that needs to be removed otherwise
7155 * it will be converted to VMS mode incorrectly.
7158 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7159 argvp[0][0][ulen] = '\0';
7162 /* We need to use this hack to tell Perl it should run with tainting,
7163 * since its tainting flag may be part of the PL_curinterp struct, which
7164 * hasn't been allocated when vms_image_init() is called.
7167 char **newargv, **oldargv;
7169 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7170 newargv[0] = oldargv[0];
7171 newargv[1] = (char *) PerlMem_malloc(3 * sizeof(char));
7172 strcpy(newargv[1], "-T");
7173 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7175 newargv[*argcp] = NULL;
7176 /* We orphan the old argv, since we don't know where it's come from,
7177 * so we don't know how to free it.
7181 else { /* Did user explicitly request tainting? */
7183 char *cp, **av = *argvp;
7184 for (i = 1; i < *argcp; i++) {
7185 if (*av[i] != '-') break;
7186 for (cp = av[i]+1; *cp; cp++) {
7187 if (*cp == 'T') { will_taint = 1; break; }
7188 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7189 strchr("DFIiMmx",*cp)) break;
7191 if (will_taint) break;
7196 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7198 if (!tabidx) tabvec = (struct dsc$descriptor_s **) PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7199 else if (tabidx >= tabct) {
7201 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7203 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7204 tabvec[tabidx]->dsc$w_length = 0;
7205 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
7206 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
7207 tabvec[tabidx]->dsc$a_pointer = NULL;
7208 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7210 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7212 getredirection(argcp,argvp);
7213 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7215 # include <reentrancy.h>
7216 decc$set_reentrancy(C$C_MULTITHREAD);
7225 * Trim Unix-style prefix off filespec, so it looks like what a shell
7226 * glob expansion would return (i.e. from specified prefix on, not
7227 * full path). Note that returned filespec is Unix-style, regardless
7228 * of whether input filespec was VMS-style or Unix-style.
7230 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7231 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
7232 * vector of options; at present, only bit 0 is used, and if set tells
7233 * trim unixpath to try the current default directory as a prefix when
7234 * presented with a possibly ambiguous ... wildcard.
7236 * Returns !=0 on success, with trimmed filespec replacing contents of
7237 * fspec, and 0 on failure, with contents of fpsec unchanged.
7239 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7241 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7243 char *unixified, *unixwild,
7244 *template, *base, *end, *cp1, *cp2;
7245 register int tmplen, reslen = 0, dirs = 0;
7247 Newx(unixwild, VMS_MAXRSS, char);
7248 if (!wildspec || !fspec) return 0;
7249 template = unixwild;
7250 if (strpbrk(wildspec,"]>:") != NULL) {
7251 if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7257 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7258 unixwild[VMS_MAXRSS-1] = 0;
7260 Newx(unixified, VMS_MAXRSS, char);
7261 if (strpbrk(fspec,"]>:") != NULL) {
7262 if (do_tounixspec(fspec,unixified,0) == NULL) {
7264 Safefree(unixified);
7267 else base = unixified;
7268 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7269 * check to see that final result fits into (isn't longer than) fspec */
7270 reslen = strlen(fspec);
7274 /* No prefix or absolute path on wildcard, so nothing to remove */
7275 if (!*template || *template == '/') {
7277 if (base == fspec) {
7278 Safefree(unixified);
7281 tmplen = strlen(unixified);
7282 if (tmplen > reslen) {
7283 Safefree(unixified);
7284 return 0; /* not enough space */
7286 /* Copy unixified resultant, including trailing NUL */
7287 memmove(fspec,unixified,tmplen+1);
7288 Safefree(unixified);
7292 for (end = base; *end; end++) ; /* Find end of resultant filespec */
7293 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7294 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7295 for (cp1 = end ;cp1 >= base; cp1--)
7296 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7298 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7299 Safefree(unixified);
7305 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7306 int ells = 1, totells, segdirs, match;
7307 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7308 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7310 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7312 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7313 Newx(tpl, VMS_MAXRSS, char);
7314 if (ellipsis == template && opts & 1) {
7315 /* Template begins with an ellipsis. Since we can't tell how many
7316 * directory names at the front of the resultant to keep for an
7317 * arbitrary starting point, we arbitrarily choose the current
7318 * default directory as a starting point. If it's there as a prefix,
7319 * clip it off. If not, fall through and act as if the leading
7320 * ellipsis weren't there (i.e. return shortest possible path that
7321 * could match template).
7323 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7325 Safefree(unixified);
7329 if (!decc_efs_case_preserve) {
7330 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7331 if (_tolower(*cp1) != _tolower(*cp2)) break;
7333 segdirs = dirs - totells; /* Min # of dirs we must have left */
7334 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7335 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7336 memmove(fspec,cp2+1,end - cp2);
7337 Safefree(unixified);
7343 /* First off, back up over constant elements at end of path */
7345 for (front = end ; front >= base; front--)
7346 if (*front == '/' && !dirs--) { front++; break; }
7348 Newx(lcres, VMS_MAXRSS, char);
7349 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7351 if (!decc_efs_case_preserve) {
7352 *cp2 = _tolower(*cp1); /* Make lc copy for match */
7359 Safefree(unixified);
7363 return 0; /* Path too long. */
7366 *cp2 = '\0'; /* Pick up with memcpy later */
7367 lcfront = lcres + (front - base);
7368 /* Now skip over each ellipsis and try to match the path in front of it. */
7370 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7371 if (*(cp1) == '.' && *(cp1+1) == '.' &&
7372 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
7373 if (cp1 < template) break; /* template started with an ellipsis */
7374 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7375 ellipsis = cp1; continue;
7377 wilddsc.dsc$a_pointer = tpl;
7378 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7380 for (segdirs = 0, cp2 = tpl;
7381 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7383 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7385 if (!decc_efs_case_preserve) {
7386 *cp2 = _tolower(*cp1); /* else lowercase for match */
7389 *cp2 = *cp1; /* else preserve case for match */
7392 if (*cp2 == '/') segdirs++;
7394 if (cp1 != ellipsis - 1) {
7395 Safefree(unixified);
7399 return 0; /* Path too long */
7401 /* Back up at least as many dirs as in template before matching */
7402 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7403 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7404 for (match = 0; cp1 > lcres;) {
7405 resdsc.dsc$a_pointer = cp1;
7406 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7408 if (match == 1) lcfront = cp1;
7410 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7413 Safefree(unixified);
7417 return 0; /* Can't find prefix ??? */
7419 if (match > 1 && opts & 1) {
7420 /* This ... wildcard could cover more than one set of dirs (i.e.
7421 * a set of similar dir names is repeated). If the template
7422 * contains more than 1 ..., upstream elements could resolve the
7423 * ambiguity, but it's not worth a full backtracking setup here.
7424 * As a quick heuristic, clip off the current default directory
7425 * if it's present to find the trimmed spec, else use the
7426 * shortest string that this ... could cover.
7428 char def[NAM$C_MAXRSS+1], *st;
7430 if (getcwd(def, sizeof def,0) == NULL) {
7431 Safefree(unixified);
7437 if (!decc_efs_case_preserve) {
7438 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7439 if (_tolower(*cp1) != _tolower(*cp2)) break;
7441 segdirs = dirs - totells; /* Min # of dirs we must have left */
7442 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7443 if (*cp1 == '\0' && *cp2 == '/') {
7444 memmove(fspec,cp2+1,end - cp2);
7446 Safefree(unixified);
7451 /* Nope -- stick with lcfront from above and keep going. */
7454 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7455 Safefree(unixified);
7463 } /* end of trim_unixpath() */
7468 * VMS readdir() routines.
7469 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7471 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
7472 * Minor modifications to original routines.
7475 /* readdir may have been redefined by reentr.h, so make sure we get
7476 * the local version for what we do here.
7481 #if !defined(PERL_IMPLICIT_CONTEXT)
7482 # define readdir Perl_readdir
7484 # define readdir(a) Perl_readdir(aTHX_ a)
7487 /* Number of elements in vms_versions array */
7488 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
7491 * Open a directory, return a handle for later use.
7493 /*{{{ DIR *opendir(char*name) */
7495 Perl_opendir(pTHX_ const char *name)
7498 char dir[NAM$C_MAXRSS+1];
7501 if (do_tovmspath(name,dir,0) == NULL) {
7504 /* Check access before stat; otherwise stat does not
7505 * accurately report whether it's a directory.
7507 if (!cando_by_name(S_IRUSR,0,dir)) {
7508 /* cando_by_name has already set errno */
7511 if (flex_stat(dir,&sb) == -1) return NULL;
7512 if (!S_ISDIR(sb.st_mode)) {
7513 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
7516 /* Get memory for the handle, and the pattern. */
7518 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7520 /* Fill in the fields; mainly playing with the descriptor. */
7521 sprintf(dd->pattern, "%s*.*",dir);
7524 dd->vms_wantversions = 0;
7525 dd->pat.dsc$a_pointer = dd->pattern;
7526 dd->pat.dsc$w_length = strlen(dd->pattern);
7527 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7528 dd->pat.dsc$b_class = DSC$K_CLASS_S;
7529 #if defined(USE_ITHREADS)
7530 Newx(dd->mutex,1,perl_mutex);
7531 MUTEX_INIT( (perl_mutex *) dd->mutex );
7537 } /* end of opendir() */
7541 * Set the flag to indicate we want versions or not.
7543 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7545 vmsreaddirversions(DIR *dd, int flag)
7547 dd->vms_wantversions = flag;
7552 * Free up an opened directory.
7554 /*{{{ void closedir(DIR *dd)*/
7556 Perl_closedir(DIR *dd)
7560 sts = lib$find_file_end(&dd->context);
7561 Safefree(dd->pattern);
7562 #if defined(USE_ITHREADS)
7563 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7564 Safefree(dd->mutex);
7571 * Collect all the version numbers for the current file.
7574 collectversions(pTHX_ DIR *dd)
7576 struct dsc$descriptor_s pat;
7577 struct dsc$descriptor_s res;
7579 char *p, *text, buff[sizeof dd->entry.d_name];
7581 unsigned long context, tmpsts;
7583 /* Convenient shorthand. */
7586 /* Add the version wildcard, ignoring the "*.*" put on before */
7587 i = strlen(dd->pattern);
7588 Newx(text,i + e->d_namlen + 3,char);
7589 strcpy(text, dd->pattern);
7590 sprintf(&text[i - 3], "%s;*", e->d_name);
7592 /* Set up the pattern descriptor. */
7593 pat.dsc$a_pointer = text;
7594 pat.dsc$w_length = i + e->d_namlen - 1;
7595 pat.dsc$b_dtype = DSC$K_DTYPE_T;
7596 pat.dsc$b_class = DSC$K_CLASS_S;
7598 /* Set up result descriptor. */
7599 res.dsc$a_pointer = buff;
7600 res.dsc$w_length = sizeof buff - 2;
7601 res.dsc$b_dtype = DSC$K_DTYPE_T;
7602 res.dsc$b_class = DSC$K_CLASS_S;
7604 /* Read files, collecting versions. */
7605 for (context = 0, e->vms_verscount = 0;
7606 e->vms_verscount < VERSIZE(e);
7607 e->vms_verscount++) {
7608 tmpsts = lib$find_file(&pat, &res, &context);
7609 if (tmpsts == RMS$_NMF || context == 0) break;
7611 buff[sizeof buff - 1] = '\0';
7612 if ((p = strchr(buff, ';')))
7613 e->vms_versions[e->vms_verscount] = atoi(p + 1);
7615 e->vms_versions[e->vms_verscount] = -1;
7618 _ckvmssts(lib$find_file_end(&context));
7621 } /* end of collectversions() */
7624 * Read the next entry from the directory.
7626 /*{{{ struct dirent *readdir(DIR *dd)*/
7628 Perl_readdir(pTHX_ DIR *dd)
7630 struct dsc$descriptor_s res;
7631 char *p, buff[sizeof dd->entry.d_name];
7632 unsigned long int tmpsts;
7634 /* Set up result descriptor, and get next file. */
7635 res.dsc$a_pointer = buff;
7636 res.dsc$w_length = sizeof buff - 2;
7637 res.dsc$b_dtype = DSC$K_DTYPE_T;
7638 res.dsc$b_class = DSC$K_CLASS_S;
7639 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
7640 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
7641 if (!(tmpsts & 1)) {
7642 set_vaxc_errno(tmpsts);
7645 set_errno(EACCES); break;
7647 set_errno(ENODEV); break;
7649 set_errno(ENOTDIR); break;
7650 case RMS$_FNF: case RMS$_DNF:
7651 set_errno(ENOENT); break;
7658 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
7659 if (!decc_efs_case_preserve) {
7660 buff[sizeof buff - 1] = '\0';
7661 for (p = buff; *p; p++) *p = _tolower(*p);
7662 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7666 /* we don't want to force to lowercase, just null terminate */
7667 buff[res.dsc$w_length] = '\0';
7669 for (p = buff; *p; p++) *p = _tolower(*p);
7670 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7673 /* Skip any directory component and just copy the name. */
7674 if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1);
7675 else strcpy(dd->entry.d_name, buff);
7677 /* Clobber the version. */
7678 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
7680 dd->entry.d_namlen = strlen(dd->entry.d_name);
7681 dd->entry.vms_verscount = 0;
7682 if (dd->vms_wantversions) collectversions(aTHX_ dd);
7685 } /* end of readdir() */
7689 * Read the next entry from the directory -- thread-safe version.
7691 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
7693 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
7697 MUTEX_LOCK( (perl_mutex *) dd->mutex );
7699 entry = readdir(dd);
7701 retval = ( *result == NULL ? errno : 0 );
7703 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
7707 } /* end of readdir_r() */
7711 * Return something that can be used in a seekdir later.
7713 /*{{{ long telldir(DIR *dd)*/
7715 Perl_telldir(DIR *dd)
7722 * Return to a spot where we used to be. Brute force.
7724 /*{{{ void seekdir(DIR *dd,long count)*/
7726 Perl_seekdir(pTHX_ DIR *dd, long count)
7728 int vms_wantversions;
7730 /* If we haven't done anything yet... */
7734 /* Remember some state, and clear it. */
7735 vms_wantversions = dd->vms_wantversions;
7736 dd->vms_wantversions = 0;
7737 _ckvmssts(lib$find_file_end(&dd->context));
7740 /* The increment is in readdir(). */
7741 for (dd->count = 0; dd->count < count; )
7744 dd->vms_wantversions = vms_wantversions;
7746 } /* end of seekdir() */
7749 /* VMS subprocess management
7751 * my_vfork() - just a vfork(), after setting a flag to record that
7752 * the current script is trying a Unix-style fork/exec.
7754 * vms_do_aexec() and vms_do_exec() are called in response to the
7755 * perl 'exec' function. If this follows a vfork call, then they
7756 * call out the regular perl routines in doio.c which do an
7757 * execvp (for those who really want to try this under VMS).
7758 * Otherwise, they do exactly what the perl docs say exec should
7759 * do - terminate the current script and invoke a new command
7760 * (See below for notes on command syntax.)
7762 * do_aspawn() and do_spawn() implement the VMS side of the perl
7763 * 'system' function.
7765 * Note on command arguments to perl 'exec' and 'system': When handled
7766 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
7767 * are concatenated to form a DCL command string. If the first arg
7768 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
7769 * the command string is handed off to DCL directly. Otherwise,
7770 * the first token of the command is taken as the filespec of an image
7771 * to run. The filespec is expanded using a default type of '.EXE' and
7772 * the process defaults for device, directory, etc., and if found, the resultant
7773 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
7774 * the command string as parameters. This is perhaps a bit complicated,
7775 * but I hope it will form a happy medium between what VMS folks expect
7776 * from lib$spawn and what Unix folks expect from exec.
7779 static int vfork_called;
7781 /*{{{int my_vfork()*/
7792 vms_execfree(struct dsc$descriptor_s *vmscmd)
7795 if (vmscmd->dsc$a_pointer) {
7796 Safefree(vmscmd->dsc$a_pointer);
7803 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
7805 char *junk, *tmps = Nullch;
7806 register size_t cmdlen = 0;
7813 tmps = SvPV(really,rlen);
7820 for (idx++; idx <= sp; idx++) {
7822 junk = SvPVx(*idx,rlen);
7823 cmdlen += rlen ? rlen + 1 : 0;
7826 Newx(PL_Cmd,cmdlen+1,char);
7828 if (tmps && *tmps) {
7829 strcpy(PL_Cmd,tmps);
7832 else *PL_Cmd = '\0';
7833 while (++mark <= sp) {
7835 char *s = SvPVx(*mark,n_a);
7837 if (*PL_Cmd) strcat(PL_Cmd," ");
7843 } /* end of setup_argstr() */
7846 static unsigned long int
7847 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
7848 struct dsc$descriptor_s **pvmscmd)
7850 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
7851 char image_name[NAM$C_MAXRSS+1];
7852 char image_argv[NAM$C_MAXRSS+1];
7853 $DESCRIPTOR(defdsc,".EXE");
7854 $DESCRIPTOR(defdsc2,".");
7855 $DESCRIPTOR(resdsc,resspec);
7856 struct dsc$descriptor_s *vmscmd;
7857 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7858 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
7859 register char *s, *rest, *cp, *wordbreak;
7864 Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
7866 /* Make a copy for modification */
7867 cmdlen = strlen(incmd);
7868 Newx(cmd, cmdlen+1, char);
7869 strncpy(cmd, incmd, cmdlen);
7874 vmscmd->dsc$a_pointer = NULL;
7875 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
7876 vmscmd->dsc$b_class = DSC$K_CLASS_S;
7877 vmscmd->dsc$w_length = 0;
7878 if (pvmscmd) *pvmscmd = vmscmd;
7880 if (suggest_quote) *suggest_quote = 0;
7882 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
7883 return CLI$_BUFOVF; /* continuation lines currently unsupported */
7889 while (*s && isspace(*s)) s++;
7891 if (*s == '@' || *s == '$') {
7892 vmsspec[0] = *s; rest = s + 1;
7893 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
7895 else { cp = vmsspec; rest = s; }
7896 if (*rest == '.' || *rest == '/') {
7899 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
7900 rest++, cp2++) *cp2 = *rest;
7902 if (do_tovmsspec(resspec,cp,0)) {
7905 for (cp2 = vmsspec + strlen(vmsspec);
7906 *rest && cp2 - vmsspec < sizeof vmsspec;
7907 rest++, cp2++) *cp2 = *rest;
7912 /* Intuit whether verb (first word of cmd) is a DCL command:
7913 * - if first nonspace char is '@', it's a DCL indirection
7915 * - if verb contains a filespec separator, it's not a DCL command
7916 * - if it doesn't, caller tells us whether to default to a DCL
7917 * command, or to a local image unless told it's DCL (by leading '$')
7921 if (suggest_quote) *suggest_quote = 1;
7923 register char *filespec = strpbrk(s,":<[.;");
7924 rest = wordbreak = strpbrk(s," \"\t/");
7925 if (!wordbreak) wordbreak = s + strlen(s);
7926 if (*s == '$') check_img = 0;
7927 if (filespec && (filespec < wordbreak)) isdcl = 0;
7928 else isdcl = !check_img;
7932 imgdsc.dsc$a_pointer = s;
7933 imgdsc.dsc$w_length = wordbreak - s;
7934 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7936 _ckvmssts(lib$find_file_end(&cxt));
7937 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7938 if (!(retsts & 1) && *s == '$') {
7939 _ckvmssts(lib$find_file_end(&cxt));
7940 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
7941 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7943 _ckvmssts(lib$find_file_end(&cxt));
7944 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7948 _ckvmssts(lib$find_file_end(&cxt));
7953 while (*s && !isspace(*s)) s++;
7956 /* check that it's really not DCL with no file extension */
7957 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
7959 char b[256] = {0,0,0,0};
7960 read(fileno(fp), b, 256);
7961 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
7965 /* Check for script */
7967 if ((b[0] == '#') && (b[1] == '!'))
7969 #ifdef ALTERNATE_SHEBANG
7971 shebang_len = strlen(ALTERNATE_SHEBANG);
7972 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
7974 perlstr = strstr("perl",b);
7975 if (perlstr == NULL)
7983 if (shebang_len > 0) {
7986 char tmpspec[NAM$C_MAXRSS + 1];
7989 /* Image is following after white space */
7990 /*--------------------------------------*/
7991 while (isprint(b[i]) && isspace(b[i]))
7995 while (isprint(b[i]) && !isspace(b[i])) {
7996 tmpspec[j++] = b[i++];
7997 if (j >= NAM$C_MAXRSS)
8002 /* There may be some default parameters to the image */
8003 /*---------------------------------------------------*/
8005 while (isprint(b[i])) {
8006 image_argv[j++] = b[i++];
8007 if (j >= NAM$C_MAXRSS)
8010 while ((j > 0) && !isprint(image_argv[j-1]))
8014 /* It will need to be converted to VMS format and validated */
8015 if (tmpspec[0] != '\0') {
8018 /* Try to find the exact program requested to be run */
8019 /*---------------------------------------------------*/
8020 iname = do_rmsexpand
8021 (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8022 if (iname != NULL) {
8023 if (cando_by_name(S_IXUSR,0,image_name)) {
8024 /* MCR prefix needed */
8028 /* Try again with a null type */
8029 /*----------------------------*/
8030 iname = do_rmsexpand
8031 (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8032 if (iname != NULL) {
8033 if (cando_by_name(S_IXUSR,0,image_name)) {
8034 /* MCR prefix needed */
8040 /* Did we find the image to run the script? */
8041 /*------------------------------------------*/
8045 /* Assume DCL or foreign command exists */
8046 /*--------------------------------------*/
8047 tchr = strrchr(tmpspec, '/');
8054 strcpy(image_name, tchr);
8062 if (check_img && isdcl) return RMS$_FNF;
8064 if (cando_by_name(S_IXUSR,0,resspec)) {
8065 Newx(vmscmd->dsc$a_pointer, MAX_DCL_LINE_LENGTH ,char);
8067 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8068 if (image_name[0] != 0) {
8069 strcat(vmscmd->dsc$a_pointer, image_name);
8070 strcat(vmscmd->dsc$a_pointer, " ");
8072 } else if (image_name[0] != 0) {
8073 strcpy(vmscmd->dsc$a_pointer, image_name);
8074 strcat(vmscmd->dsc$a_pointer, " ");
8076 strcpy(vmscmd->dsc$a_pointer,"@");
8078 if (suggest_quote) *suggest_quote = 1;
8080 /* If there is an image name, use original command */
8081 if (image_name[0] == 0)
8082 strcat(vmscmd->dsc$a_pointer,resspec);
8085 while (*rest && isspace(*rest)) rest++;
8088 if (image_argv[0] != 0) {
8089 strcat(vmscmd->dsc$a_pointer,image_argv);
8090 strcat(vmscmd->dsc$a_pointer, " ");
8096 rest_len = strlen(rest);
8097 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8098 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8099 strcat(vmscmd->dsc$a_pointer,rest);
8101 retsts = CLI$_BUFOVF;
8103 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8105 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8107 else retsts = RMS$_PRV;
8110 /* It's either a DCL command or we couldn't find a suitable image */
8111 vmscmd->dsc$w_length = strlen(cmd);
8112 /* if (cmd == PL_Cmd) {
8113 vmscmd->dsc$a_pointer = PL_Cmd;
8114 if (suggest_quote) *suggest_quote = 1;
8117 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
8121 /* check if it's a symbol (for quoting purposes) */
8122 if (suggest_quote && !*suggest_quote) {
8124 char equiv[LNM$C_NAMLENGTH];
8125 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8126 eqvdsc.dsc$a_pointer = equiv;
8128 iss = lib$get_symbol(vmscmd,&eqvdsc);
8129 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8131 if (!(retsts & 1)) {
8132 /* just hand off status values likely to be due to user error */
8133 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8134 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8135 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8136 else { _ckvmssts(retsts); }
8139 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8141 } /* end of setup_cmddsc() */
8144 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8146 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8149 if (vfork_called) { /* this follows a vfork - act Unixish */
8151 if (vfork_called < 0) {
8152 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8155 else return do_aexec(really,mark,sp);
8157 /* no vfork - act VMSish */
8158 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
8163 } /* end of vms_do_aexec() */
8166 /* {{{bool vms_do_exec(char *cmd) */
8168 Perl_vms_do_exec(pTHX_ const char *cmd)
8170 struct dsc$descriptor_s *vmscmd;
8172 if (vfork_called) { /* this follows a vfork - act Unixish */
8174 if (vfork_called < 0) {
8175 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8178 else return do_exec(cmd);
8181 { /* no vfork - act VMSish */
8182 unsigned long int retsts;
8185 TAINT_PROPER("exec");
8186 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8187 retsts = lib$do_command(vmscmd);
8190 case RMS$_FNF: case RMS$_DNF:
8191 set_errno(ENOENT); break;
8193 set_errno(ENOTDIR); break;
8195 set_errno(ENODEV); break;
8197 set_errno(EACCES); break;
8199 set_errno(EINVAL); break;
8200 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8201 set_errno(E2BIG); break;
8202 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8203 _ckvmssts(retsts); /* fall through */
8204 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8207 set_vaxc_errno(retsts);
8208 if (ckWARN(WARN_EXEC)) {
8209 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8210 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8212 vms_execfree(vmscmd);
8217 } /* end of vms_do_exec() */
8220 unsigned long int Perl_do_spawn(pTHX_ const char *);
8222 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8224 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8226 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
8229 } /* end of do_aspawn() */
8232 /* {{{unsigned long int do_spawn(char *cmd) */
8234 Perl_do_spawn(pTHX_ const char *cmd)
8236 unsigned long int sts, substs;
8239 TAINT_PROPER("spawn");
8240 if (!cmd || !*cmd) {
8241 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8244 case RMS$_FNF: case RMS$_DNF:
8245 set_errno(ENOENT); break;
8247 set_errno(ENOTDIR); break;
8249 set_errno(ENODEV); break;
8251 set_errno(EACCES); break;
8253 set_errno(EINVAL); break;
8254 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8255 set_errno(E2BIG); break;
8256 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8257 _ckvmssts(sts); /* fall through */
8258 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8261 set_vaxc_errno(sts);
8262 if (ckWARN(WARN_EXEC)) {
8263 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8271 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8276 } /* end of do_spawn() */
8280 static unsigned int *sockflags, sockflagsize;
8283 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8284 * routines found in some versions of the CRTL can't deal with sockets.
8285 * We don't shim the other file open routines since a socket isn't
8286 * likely to be opened by a name.
8288 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8289 FILE *my_fdopen(int fd, const char *mode)
8291 FILE *fp = fdopen(fd, mode);
8294 unsigned int fdoff = fd / sizeof(unsigned int);
8295 Stat_t sbuf; /* native stat; we don't need flex_stat */
8296 if (!sockflagsize || fdoff > sockflagsize) {
8297 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
8298 else Newx (sockflags,fdoff+2,unsigned int);
8299 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8300 sockflagsize = fdoff + 2;
8302 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8303 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8312 * Clear the corresponding bit when the (possibly) socket stream is closed.
8313 * There still a small hole: we miss an implicit close which might occur
8314 * via freopen(). >> Todo
8316 /*{{{ int my_fclose(FILE *fp)*/
8317 int my_fclose(FILE *fp) {
8319 unsigned int fd = fileno(fp);
8320 unsigned int fdoff = fd / sizeof(unsigned int);
8322 if (sockflagsize && fdoff <= sockflagsize)
8323 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8331 * A simple fwrite replacement which outputs itmsz*nitm chars without
8332 * introducing record boundaries every itmsz chars.
8333 * We are using fputs, which depends on a terminating null. We may
8334 * well be writing binary data, so we need to accommodate not only
8335 * data with nulls sprinkled in the middle but also data with no null
8338 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8340 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8342 register char *cp, *end, *cpd, *data;
8343 register unsigned int fd = fileno(dest);
8344 register unsigned int fdoff = fd / sizeof(unsigned int);
8346 int bufsize = itmsz * nitm + 1;
8348 if (fdoff < sockflagsize &&
8349 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8350 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8354 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8355 memcpy( data, src, itmsz*nitm );
8356 data[itmsz*nitm] = '\0';
8358 end = data + itmsz * nitm;
8359 retval = (int) nitm; /* on success return # items written */
8362 while (cpd <= end) {
8363 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8364 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8366 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8370 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8373 } /* end of my_fwrite() */
8376 /*{{{ int my_flush(FILE *fp)*/
8378 Perl_my_flush(pTHX_ FILE *fp)
8381 if ((res = fflush(fp)) == 0 && fp) {
8382 #ifdef VMS_DO_SOCKETS
8384 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8386 res = fsync(fileno(fp));
8389 * If the flush succeeded but set end-of-file, we need to clear
8390 * the error because our caller may check ferror(). BTW, this
8391 * probably means we just flushed an empty file.
8393 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8400 * Here are replacements for the following Unix routines in the VMS environment:
8401 * getpwuid Get information for a particular UIC or UID
8402 * getpwnam Get information for a named user
8403 * getpwent Get information for each user in the rights database
8404 * setpwent Reset search to the start of the rights database
8405 * endpwent Finish searching for users in the rights database
8407 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8408 * (defined in pwd.h), which contains the following fields:-
8410 * char *pw_name; Username (in lower case)
8411 * char *pw_passwd; Hashed password
8412 * unsigned int pw_uid; UIC
8413 * unsigned int pw_gid; UIC group number
8414 * char *pw_unixdir; Default device/directory (VMS-style)
8415 * char *pw_gecos; Owner name
8416 * char *pw_dir; Default device/directory (Unix-style)
8417 * char *pw_shell; Default CLI name (eg. DCL)
8419 * If the specified user does not exist, getpwuid and getpwnam return NULL.
8421 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8422 * not the UIC member number (eg. what's returned by getuid()),
8423 * getpwuid() can accept either as input (if uid is specified, the caller's
8424 * UIC group is used), though it won't recognise gid=0.
8426 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8427 * information about other users in your group or in other groups, respectively.
8428 * If the required privilege is not available, then these routines fill only
8429 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8432 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8435 /* sizes of various UAF record fields */
8436 #define UAI$S_USERNAME 12
8437 #define UAI$S_IDENT 31
8438 #define UAI$S_OWNER 31
8439 #define UAI$S_DEFDEV 31
8440 #define UAI$S_DEFDIR 63
8441 #define UAI$S_DEFCLI 31
8444 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
8445 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8446 (uic).uic$v_group != UIC$K_WILD_GROUP)
8448 static char __empty[]= "";
8449 static struct passwd __passwd_empty=
8450 {(char *) __empty, (char *) __empty, 0, 0,
8451 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8452 static int contxt= 0;
8453 static struct passwd __pwdcache;
8454 static char __pw_namecache[UAI$S_IDENT+1];
8457 * This routine does most of the work extracting the user information.
8459 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8462 unsigned char length;
8463 char pw_gecos[UAI$S_OWNER+1];
8465 static union uicdef uic;
8467 unsigned char length;
8468 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8471 unsigned char length;
8472 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8475 unsigned char length;
8476 char pw_shell[UAI$S_DEFCLI+1];
8478 static char pw_passwd[UAI$S_PWD+1];
8480 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8481 struct dsc$descriptor_s name_desc;
8482 unsigned long int sts;
8484 static struct itmlst_3 itmlst[]= {
8485 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
8486 {sizeof(uic), UAI$_UIC, &uic, &luic},
8487 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
8488 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
8489 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
8490 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
8491 {0, 0, NULL, NULL}};
8493 name_desc.dsc$w_length= strlen(name);
8494 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
8495 name_desc.dsc$b_class= DSC$K_CLASS_S;
8496 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8498 /* Note that sys$getuai returns many fields as counted strings. */
8499 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8500 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8501 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8503 else { _ckvmssts(sts); }
8504 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
8506 if ((int) owner.length < lowner) lowner= (int) owner.length;
8507 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8508 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8509 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8510 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8511 owner.pw_gecos[lowner]= '\0';
8512 defdev.pw_dir[ldefdev+ldefdir]= '\0';
8513 defcli.pw_shell[ldefcli]= '\0';
8514 if (valid_uic(uic)) {
8515 pwd->pw_uid= uic.uic$l_uic;
8516 pwd->pw_gid= uic.uic$v_group;
8519 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8520 pwd->pw_passwd= pw_passwd;
8521 pwd->pw_gecos= owner.pw_gecos;
8522 pwd->pw_dir= defdev.pw_dir;
8523 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8524 pwd->pw_shell= defcli.pw_shell;
8525 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8527 ldir= strlen(pwd->pw_unixdir) - 1;
8528 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8531 strcpy(pwd->pw_unixdir, pwd->pw_dir);
8532 if (!decc_efs_case_preserve)
8533 __mystrtolower(pwd->pw_unixdir);
8538 * Get information for a named user.
8540 /*{{{struct passwd *getpwnam(char *name)*/
8541 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8543 struct dsc$descriptor_s name_desc;
8545 unsigned long int status, sts;
8547 __pwdcache = __passwd_empty;
8548 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8549 /* We still may be able to determine pw_uid and pw_gid */
8550 name_desc.dsc$w_length= strlen(name);
8551 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
8552 name_desc.dsc$b_class= DSC$K_CLASS_S;
8553 name_desc.dsc$a_pointer= (char *) name;
8554 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
8555 __pwdcache.pw_uid= uic.uic$l_uic;
8556 __pwdcache.pw_gid= uic.uic$v_group;
8559 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8560 set_vaxc_errno(sts);
8561 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
8564 else { _ckvmssts(sts); }
8567 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8568 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8569 __pwdcache.pw_name= __pw_namecache;
8571 } /* end of my_getpwnam() */
8575 * Get information for a particular UIC or UID.
8576 * Called by my_getpwent with uid=-1 to list all users.
8578 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
8579 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
8581 const $DESCRIPTOR(name_desc,__pw_namecache);
8582 unsigned short lname;
8584 unsigned long int status;
8586 if (uid == (unsigned int) -1) {
8588 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
8589 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
8590 set_vaxc_errno(status);
8591 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8595 else { _ckvmssts(status); }
8596 } while (!valid_uic (uic));
8600 if (!uic.uic$v_group)
8601 uic.uic$v_group= PerlProc_getgid();
8603 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
8604 else status = SS$_IVIDENT;
8605 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
8606 status == RMS$_PRV) {
8607 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8610 else { _ckvmssts(status); }
8612 __pw_namecache[lname]= '\0';
8613 __mystrtolower(__pw_namecache);
8615 __pwdcache = __passwd_empty;
8616 __pwdcache.pw_name = __pw_namecache;
8618 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
8619 The identifier's value is usually the UIC, but it doesn't have to be,
8620 so if we can, we let fillpasswd update this. */
8621 __pwdcache.pw_uid = uic.uic$l_uic;
8622 __pwdcache.pw_gid = uic.uic$v_group;
8624 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
8627 } /* end of my_getpwuid() */
8631 * Get information for next user.
8633 /*{{{struct passwd *my_getpwent()*/
8634 struct passwd *Perl_my_getpwent(pTHX)
8636 return (my_getpwuid((unsigned int) -1));
8641 * Finish searching rights database for users.
8643 /*{{{void my_endpwent()*/
8644 void Perl_my_endpwent(pTHX)
8647 _ckvmssts(sys$finish_rdb(&contxt));
8653 #ifdef HOMEGROWN_POSIX_SIGNALS
8654 /* Signal handling routines, pulled into the core from POSIX.xs.
8656 * We need these for threads, so they've been rolled into the core,
8657 * rather than left in POSIX.xs.
8659 * (DRS, Oct 23, 1997)
8662 /* sigset_t is atomic under VMS, so these routines are easy */
8663 /*{{{int my_sigemptyset(sigset_t *) */
8664 int my_sigemptyset(sigset_t *set) {
8665 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8671 /*{{{int my_sigfillset(sigset_t *)*/
8672 int my_sigfillset(sigset_t *set) {
8674 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8675 for (i = 0; i < NSIG; i++) *set |= (1 << i);
8681 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
8682 int my_sigaddset(sigset_t *set, int sig) {
8683 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8684 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8685 *set |= (1 << (sig - 1));
8691 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
8692 int my_sigdelset(sigset_t *set, int sig) {
8693 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8694 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8695 *set &= ~(1 << (sig - 1));
8701 /*{{{int my_sigismember(sigset_t *set, int sig)*/
8702 int my_sigismember(sigset_t *set, int sig) {
8703 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8704 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8705 return *set & (1 << (sig - 1));
8710 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
8711 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
8714 /* If set and oset are both null, then things are badly wrong. Bail out. */
8715 if ((oset == NULL) && (set == NULL)) {
8716 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
8720 /* If set's null, then we're just handling a fetch. */
8722 tempmask = sigblock(0);
8727 tempmask = sigsetmask(*set);
8730 tempmask = sigblock(*set);
8733 tempmask = sigblock(0);
8734 sigsetmask(*oset & ~tempmask);
8737 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8742 /* Did they pass us an oset? If so, stick our holding mask into it */
8749 #endif /* HOMEGROWN_POSIX_SIGNALS */
8752 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
8753 * my_utime(), and flex_stat(), all of which operate on UTC unless
8754 * VMSISH_TIMES is true.
8756 /* method used to handle UTC conversions:
8757 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
8759 static int gmtime_emulation_type;
8760 /* number of secs to add to UTC POSIX-style time to get local time */
8761 static long int utc_offset_secs;
8763 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
8764 * in vmsish.h. #undef them here so we can call the CRTL routines
8773 * DEC C previous to 6.0 corrupts the behavior of the /prefix
8774 * qualifier with the extern prefix pragma. This provisional
8775 * hack circumvents this prefix pragma problem in previous
8778 #if defined(__VMS_VER) && __VMS_VER >= 70000000
8779 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
8780 # pragma __extern_prefix save
8781 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
8782 # define gmtime decc$__utctz_gmtime
8783 # define localtime decc$__utctz_localtime
8784 # define time decc$__utc_time
8785 # pragma __extern_prefix restore
8787 struct tm *gmtime(), *localtime();
8793 static time_t toutc_dst(time_t loc) {
8796 if ((rsltmp = localtime(&loc)) == NULL) return -1;
8797 loc -= utc_offset_secs;
8798 if (rsltmp->tm_isdst) loc -= 3600;
8801 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
8802 ((gmtime_emulation_type || my_time(NULL)), \
8803 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
8804 ((secs) - utc_offset_secs))))
8806 static time_t toloc_dst(time_t utc) {
8809 utc += utc_offset_secs;
8810 if ((rsltmp = localtime(&utc)) == NULL) return -1;
8811 if (rsltmp->tm_isdst) utc += 3600;
8814 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
8815 ((gmtime_emulation_type || my_time(NULL)), \
8816 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
8817 ((secs) + utc_offset_secs))))
8819 #ifndef RTL_USES_UTC
8822 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
8823 DST starts on 1st sun of april at 02:00 std time
8824 ends on last sun of october at 02:00 dst time
8825 see the UCX management command reference, SET CONFIG TIMEZONE
8826 for formatting info.
8828 No, it's not as general as it should be, but then again, NOTHING
8829 will handle UK times in a sensible way.
8834 parse the DST start/end info:
8835 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
8839 tz_parse_startend(char *s, struct tm *w, int *past)
8841 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
8842 int ly, dozjd, d, m, n, hour, min, sec, j, k;
8847 if (!past) return 0;
8850 if (w->tm_year % 4 == 0) ly = 1;
8851 if (w->tm_year % 100 == 0) ly = 0;
8852 if (w->tm_year+1900 % 400 == 0) ly = 1;
8855 dozjd = isdigit(*s);
8856 if (*s == 'J' || *s == 'j' || dozjd) {
8857 if (!dozjd && !isdigit(*++s)) return 0;
8860 d = d*10 + *s++ - '0';
8862 d = d*10 + *s++ - '0';
8865 if (d == 0) return 0;
8866 if (d > 366) return 0;
8868 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
8871 } else if (*s == 'M' || *s == 'm') {
8872 if (!isdigit(*++s)) return 0;
8874 if (isdigit(*s)) m = 10*m + *s++ - '0';
8875 if (*s != '.') return 0;
8876 if (!isdigit(*++s)) return 0;
8878 if (n < 1 || n > 5) return 0;
8879 if (*s != '.') return 0;
8880 if (!isdigit(*++s)) return 0;
8882 if (d > 6) return 0;
8886 if (!isdigit(*++s)) return 0;
8888 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
8890 if (!isdigit(*++s)) return 0;
8892 if (isdigit(*s)) min = 10*min + *s++ - '0';
8894 if (!isdigit(*++s)) return 0;
8896 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
8906 if (w->tm_yday < d) goto before;
8907 if (w->tm_yday > d) goto after;
8909 if (w->tm_mon+1 < m) goto before;
8910 if (w->tm_mon+1 > m) goto after;
8912 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
8913 k = d - j; /* mday of first d */
8915 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
8916 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
8917 if (w->tm_mday < k) goto before;
8918 if (w->tm_mday > k) goto after;
8921 if (w->tm_hour < hour) goto before;
8922 if (w->tm_hour > hour) goto after;
8923 if (w->tm_min < min) goto before;
8924 if (w->tm_min > min) goto after;
8925 if (w->tm_sec < sec) goto before;
8939 /* parse the offset: (+|-)hh[:mm[:ss]] */
8942 tz_parse_offset(char *s, int *offset)
8944 int hour = 0, min = 0, sec = 0;
8947 if (!offset) return 0;
8949 if (*s == '-') {neg++; s++;}
8951 if (!isdigit(*s)) return 0;
8953 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
8954 if (hour > 24) return 0;
8956 if (!isdigit(*++s)) return 0;
8958 if (isdigit(*s)) min = min*10 + (*s++ - '0');
8959 if (min > 59) return 0;
8961 if (!isdigit(*++s)) return 0;
8963 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
8964 if (sec > 59) return 0;
8968 *offset = (hour*60+min)*60 + sec;
8969 if (neg) *offset = -*offset;
8974 input time is w, whatever type of time the CRTL localtime() uses.
8975 sets dst, the zone, and the gmtoff (seconds)
8977 caches the value of TZ and UCX$TZ env variables; note that
8978 my_setenv looks for these and sets a flag if they're changed
8981 We have to watch out for the "australian" case (dst starts in
8982 october, ends in april)...flagged by "reverse" and checked by
8983 scanning through the months of the previous year.
8988 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
8993 char *dstzone, *tz, *s_start, *s_end;
8994 int std_off, dst_off, isdst;
8995 int y, dststart, dstend;
8996 static char envtz[1025]; /* longer than any logical, symbol, ... */
8997 static char ucxtz[1025];
8998 static char reversed = 0;
9004 reversed = -1; /* flag need to check */
9005 envtz[0] = ucxtz[0] = '\0';
9006 tz = my_getenv("TZ",0);
9007 if (tz) strcpy(envtz, tz);
9008 tz = my_getenv("UCX$TZ",0);
9009 if (tz) strcpy(ucxtz, tz);
9010 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
9013 if (!*tz) tz = ucxtz;
9016 while (isalpha(*s)) s++;
9017 s = tz_parse_offset(s, &std_off);
9019 if (!*s) { /* no DST, hurray we're done! */
9025 while (isalpha(*s)) s++;
9026 s2 = tz_parse_offset(s, &dst_off);
9030 dst_off = std_off - 3600;
9033 if (!*s) { /* default dst start/end?? */
9034 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
9035 s = strchr(ucxtz,',');
9037 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
9039 if (*s != ',') return 0;
9042 when = _toutc(when); /* convert to utc */
9043 when = when - std_off; /* convert to pseudolocal time*/
9045 w2 = localtime(&when);
9048 s = tz_parse_startend(s_start,w2,&dststart);
9050 if (*s != ',') return 0;
9053 when = _toutc(when); /* convert to utc */
9054 when = when - dst_off; /* convert to pseudolocal time*/
9055 w2 = localtime(&when);
9056 if (w2->tm_year != y) { /* spans a year, just check one time */
9057 when += dst_off - std_off;
9058 w2 = localtime(&when);
9061 s = tz_parse_startend(s_end,w2,&dstend);
9064 if (reversed == -1) { /* need to check if start later than end */
9068 if (when < 2*365*86400) {
9069 when += 2*365*86400;
9073 w2 =localtime(&when);
9074 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
9076 for (j = 0; j < 12; j++) {
9077 w2 =localtime(&when);
9078 tz_parse_startend(s_start,w2,&ds);
9079 tz_parse_startend(s_end,w2,&de);
9080 if (ds != de) break;
9084 if (de && !ds) reversed = 1;
9087 isdst = dststart && !dstend;
9088 if (reversed) isdst = dststart || !dstend;
9091 if (dst) *dst = isdst;
9092 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9093 if (isdst) tz = dstzone;
9095 while(isalpha(*tz)) *zone++ = *tz++;
9101 #endif /* !RTL_USES_UTC */
9103 /* my_time(), my_localtime(), my_gmtime()
9104 * By default traffic in UTC time values, using CRTL gmtime() or
9105 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9106 * Note: We need to use these functions even when the CRTL has working
9107 * UTC support, since they also handle C<use vmsish qw(times);>
9109 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
9110 * Modified by Charles Bailey <bailey@newman.upenn.edu>
9113 /*{{{time_t my_time(time_t *timep)*/
9114 time_t Perl_my_time(pTHX_ time_t *timep)
9119 if (gmtime_emulation_type == 0) {
9121 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
9122 /* results of calls to gmtime() and localtime() */
9123 /* for same &base */
9125 gmtime_emulation_type++;
9126 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9127 char off[LNM$C_NAMLENGTH+1];;
9129 gmtime_emulation_type++;
9130 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9131 gmtime_emulation_type++;
9132 utc_offset_secs = 0;
9133 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9135 else { utc_offset_secs = atol(off); }
9137 else { /* We've got a working gmtime() */
9138 struct tm gmt, local;
9141 tm_p = localtime(&base);
9143 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
9144 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9145 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
9146 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
9152 # ifdef RTL_USES_UTC
9153 if (VMSISH_TIME) when = _toloc(when);
9155 if (!VMSISH_TIME) when = _toutc(when);
9158 if (timep != NULL) *timep = when;
9161 } /* end of my_time() */
9165 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9167 Perl_my_gmtime(pTHX_ const time_t *timep)
9173 if (timep == NULL) {
9174 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9177 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
9181 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9183 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
9184 return gmtime(&when);
9186 /* CRTL localtime() wants local time as input, so does no tz correction */
9187 rsltmp = localtime(&when);
9188 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
9191 } /* end of my_gmtime() */
9195 /*{{{struct tm *my_localtime(const time_t *timep)*/
9197 Perl_my_localtime(pTHX_ const time_t *timep)
9199 time_t when, whenutc;
9203 if (timep == NULL) {
9204 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9207 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
9208 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9211 # ifdef RTL_USES_UTC
9213 if (VMSISH_TIME) when = _toutc(when);
9215 /* CRTL localtime() wants UTC as input, does tz correction itself */
9216 return localtime(&when);
9218 # else /* !RTL_USES_UTC */
9221 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
9222 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
9225 #ifndef RTL_USES_UTC
9226 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
9227 when = whenutc - offset; /* pseudolocal time*/
9230 /* CRTL localtime() wants local time as input, so does no tz correction */
9231 rsltmp = localtime(&when);
9232 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9236 } /* end of my_localtime() */
9239 /* Reset definitions for later calls */
9240 #define gmtime(t) my_gmtime(t)
9241 #define localtime(t) my_localtime(t)
9242 #define time(t) my_time(t)
9245 /* my_utime - update modification time of a file
9246 * calling sequence is identical to POSIX utime(), but under
9247 * VMS only the modification time is changed; ODS-2 does not
9248 * maintain access times. Restrictions differ from the POSIX
9249 * definition in that the time can be changed as long as the
9250 * caller has permission to execute the necessary IO$_MODIFY $QIO;
9251 * no separate checks are made to insure that the caller is the
9252 * owner of the file or has special privs enabled.
9253 * Code here is based on Joe Meadows' FILE utility.
9256 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9257 * to VMS epoch (01-JAN-1858 00:00:00.00)
9258 * in 100 ns intervals.
9260 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9262 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9263 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9267 long int bintime[2], len = 2, lowbit, unixtime,
9268 secscale = 10000000; /* seconds --> 100 ns intervals */
9269 unsigned long int chan, iosb[2], retsts;
9270 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9271 struct FAB myfab = cc$rms_fab;
9272 struct NAM mynam = cc$rms_nam;
9273 #if defined (__DECC) && defined (__VAX)
9274 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9275 * at least through VMS V6.1, which causes a type-conversion warning.
9277 # pragma message save
9278 # pragma message disable cvtdiftypes
9280 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9281 struct fibdef myfib;
9282 #if defined (__DECC) && defined (__VAX)
9283 /* This should be right after the declaration of myatr, but due
9284 * to a bug in VAX DEC C, this takes effect a statement early.
9286 # pragma message restore
9288 /* cast ok for read only parameter */
9289 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9290 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9291 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9293 if (file == NULL || *file == '\0') {
9295 set_vaxc_errno(LIB$_INVARG);
9298 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
9300 if (utimes != NULL) {
9301 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
9302 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9303 * Since time_t is unsigned long int, and lib$emul takes a signed long int
9304 * as input, we force the sign bit to be clear by shifting unixtime right
9305 * one bit, then multiplying by an extra factor of 2 in lib$emul().
9307 lowbit = (utimes->modtime & 1) ? secscale : 0;
9308 unixtime = (long int) utimes->modtime;
9310 /* If input was UTC; convert to local for sys svc */
9311 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9313 unixtime >>= 1; secscale <<= 1;
9314 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9315 if (!(retsts & 1)) {
9317 set_vaxc_errno(retsts);
9320 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9321 if (!(retsts & 1)) {
9323 set_vaxc_errno(retsts);
9328 /* Just get the current time in VMS format directly */
9329 retsts = sys$gettim(bintime);
9330 if (!(retsts & 1)) {
9332 set_vaxc_errno(retsts);
9337 myfab.fab$l_fna = vmsspec;
9338 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9339 myfab.fab$l_nam = &mynam;
9340 mynam.nam$l_esa = esa;
9341 mynam.nam$b_ess = (unsigned char) sizeof esa;
9342 mynam.nam$l_rsa = rsa;
9343 mynam.nam$b_rss = (unsigned char) sizeof rsa;
9344 if (decc_efs_case_preserve)
9345 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9347 /* Look for the file to be affected, letting RMS parse the file
9348 * specification for us as well. I have set errno using only
9349 * values documented in the utime() man page for VMS POSIX.
9351 retsts = sys$parse(&myfab,0,0);
9352 if (!(retsts & 1)) {
9353 set_vaxc_errno(retsts);
9354 if (retsts == RMS$_PRV) set_errno(EACCES);
9355 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9356 else set_errno(EVMSERR);
9359 retsts = sys$search(&myfab,0,0);
9360 if (!(retsts & 1)) {
9361 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9362 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9363 set_vaxc_errno(retsts);
9364 if (retsts == RMS$_PRV) set_errno(EACCES);
9365 else if (retsts == RMS$_FNF) set_errno(ENOENT);
9366 else set_errno(EVMSERR);
9370 devdsc.dsc$w_length = mynam.nam$b_dev;
9371 /* cast ok for read only parameter */
9372 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9374 retsts = sys$assign(&devdsc,&chan,0,0);
9375 if (!(retsts & 1)) {
9376 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9377 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9378 set_vaxc_errno(retsts);
9379 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
9380 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
9381 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
9382 else set_errno(EVMSERR);
9386 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9387 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9389 memset((void *) &myfib, 0, sizeof myfib);
9390 #if defined(__DECC) || defined(__DECCXX)
9391 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9392 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9393 /* This prevents the revision time of the file being reset to the current
9394 * time as a result of our IO$_MODIFY $QIO. */
9395 myfib.fib$l_acctl = FIB$M_NORECORD;
9397 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9398 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9399 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9401 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9402 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9403 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9404 _ckvmssts(sys$dassgn(chan));
9405 if (retsts & 1) retsts = iosb[0];
9406 if (!(retsts & 1)) {
9407 set_vaxc_errno(retsts);
9408 if (retsts == SS$_NOPRIV) set_errno(EACCES);
9409 else set_errno(EVMSERR);
9414 } /* end of my_utime() */
9418 * flex_stat, flex_lstat, flex_fstat
9419 * basic stat, but gets it right when asked to stat
9420 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9423 #ifndef _USE_STD_STAT
9424 /* encode_dev packs a VMS device name string into an integer to allow
9425 * simple comparisons. This can be used, for example, to check whether two
9426 * files are located on the same device, by comparing their encoded device
9427 * names. Even a string comparison would not do, because stat() reuses the
9428 * device name buffer for each call; so without encode_dev, it would be
9429 * necessary to save the buffer and use strcmp (this would mean a number of
9430 * changes to the standard Perl code, to say nothing of what a Perl script
9433 * The device lock id, if it exists, should be unique (unless perhaps compared
9434 * with lock ids transferred from other nodes). We have a lock id if the disk is
9435 * mounted cluster-wide, which is when we tend to get long (host-qualified)
9436 * device names. Thus we use the lock id in preference, and only if that isn't
9437 * available, do we try to pack the device name into an integer (flagged by
9438 * the sign bit (LOCKID_MASK) being set).
9440 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9441 * name and its encoded form, but it seems very unlikely that we will find
9442 * two files on different disks that share the same encoded device names,
9443 * and even more remote that they will share the same file id (if the test
9444 * is to check for the same file).
9446 * A better method might be to use sys$device_scan on the first call, and to
9447 * search for the device, returning an index into the cached array.
9448 * The number returned would be more intelligable.
9449 * This is probably not worth it, and anyway would take quite a bit longer
9450 * on the first call.
9452 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
9453 static mydev_t encode_dev (pTHX_ const char *dev)
9456 unsigned long int f;
9461 if (!dev || !dev[0]) return 0;
9465 struct dsc$descriptor_s dev_desc;
9466 unsigned long int status, lockid, item = DVI$_LOCKID;
9468 /* For cluster-mounted disks, the disk lock identifier is unique, so we
9469 can try that first. */
9470 dev_desc.dsc$w_length = strlen (dev);
9471 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
9472 dev_desc.dsc$b_class = DSC$K_CLASS_S;
9473 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
9474 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9475 if (lockid) return (lockid & ~LOCKID_MASK);
9479 /* Otherwise we try to encode the device name */
9483 for (q = dev + strlen(dev); q--; q >= dev) {
9486 else if (isalpha (toupper (*q)))
9487 c= toupper (*q) - 'A' + (char)10;
9489 continue; /* Skip '$'s */
9491 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
9493 enc += f * (unsigned long int) c;
9495 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
9497 } /* end of encode_dev() */
9500 static char namecache[NAM$C_MAXRSS+1];
9503 is_null_device(name)
9506 if (decc_bug_devnull != 0) {
9507 if (strcmp("/dev/null", name) == 0) /* temp hack */
9510 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9511 The underscore prefix, controller letter, and unit number are
9512 independently optional; for our purposes, the colon punctuation
9513 is not. The colon can be trailed by optional directory and/or
9514 filename, but two consecutive colons indicates a nodename rather
9515 than a device. [pr] */
9516 if (*name == '_') ++name;
9517 if (tolower(*name++) != 'n') return 0;
9518 if (tolower(*name++) != 'l') return 0;
9519 if (tolower(*name) == 'a') ++name;
9520 if (*name == '0') ++name;
9521 return (*name++ == ':') && (*name != ':');
9524 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
9525 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9526 * subset of the applicable information.
9529 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
9531 char fname_phdev[NAM$C_MAXRSS+1];
9532 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9533 /* Namecache not workable with symbolic links, as symbolic links do
9534 * not have extensions and directories do in VMS mode. So in order
9535 * to test this, the did and ino_t must be used.
9537 * Fix-me - Hide the information in the new stat structure
9538 * Get rid of the namecache.
9540 if (decc_posix_compliant_pathnames == 0)
9542 if (statbufp == &PL_statcache)
9543 return cando_by_name(bit,effective,namecache);
9545 char fname[NAM$C_MAXRSS+1];
9546 unsigned long int retsts;
9547 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9548 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9550 /* If the struct mystat is stale, we're OOL; stat() overwrites the
9551 device name on successive calls */
9552 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
9553 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
9554 namdsc.dsc$a_pointer = fname;
9555 namdsc.dsc$w_length = sizeof fname - 1;
9557 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
9558 &namdsc,&namdsc.dsc$w_length,0,0);
9560 fname[namdsc.dsc$w_length] = '\0';
9562 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
9563 * but if someone has redefined that logical, Perl gets very lost. Since
9564 * we have the physical device name from the stat buffer, just paste it on.
9566 strcpy( fname_phdev, statbufp->st_devnam );
9567 strcat( fname_phdev, strrchr(fname, ':') );
9569 return cando_by_name(bit,effective,fname_phdev);
9571 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
9572 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
9576 return FALSE; /* Should never get to here */
9578 } /* end of cando() */
9582 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
9584 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
9586 static char usrname[L_cuserid];
9587 static struct dsc$descriptor_s usrdsc =
9588 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
9589 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
9590 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
9591 unsigned short int retlen, trnlnm_iter_count;
9592 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9593 union prvdef curprv;
9594 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9595 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
9596 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9597 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9599 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
9601 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9603 if (!fname || !*fname) return FALSE;
9604 /* Make sure we expand logical names, since sys$check_access doesn't */
9605 if (!strpbrk(fname,"/]>:")) {
9606 strcpy(fileified,fname);
9607 trnlnm_iter_count = 0;
9608 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
9609 trnlnm_iter_count++;
9610 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
9614 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
9615 retlen = namdsc.dsc$w_length = strlen(vmsname);
9616 namdsc.dsc$a_pointer = vmsname;
9617 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
9618 vmsname[retlen-1] == ':') {
9619 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9620 namdsc.dsc$w_length = strlen(fileified);
9621 namdsc.dsc$a_pointer = fileified;
9625 case S_IXUSR: case S_IXGRP: case S_IXOTH:
9626 access = ARM$M_EXECUTE; break;
9627 case S_IRUSR: case S_IRGRP: case S_IROTH:
9628 access = ARM$M_READ; break;
9629 case S_IWUSR: case S_IWGRP: case S_IWOTH:
9630 access = ARM$M_WRITE; break;
9631 case S_IDUSR: case S_IDGRP: case S_IDOTH:
9632 access = ARM$M_DELETE; break;
9637 /* Before we call $check_access, create a user profile with the current
9638 * process privs since otherwise it just uses the default privs from the
9639 * UAF and might give false positives or negatives. This only works on
9640 * VMS versions v6.0 and later since that's when sys$create_user_profile
9644 /* get current process privs and username */
9645 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9648 #if defined(__VMS_VER) && __VMS_VER >= 60000000
9650 /* find out the space required for the profile */
9651 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
9652 &usrprodsc.dsc$w_length,0));
9654 /* allocate space for the profile and get it filled in */
9655 Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
9656 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
9657 &usrprodsc.dsc$w_length,0));
9659 /* use the profile to check access to the file; free profile & analyze results */
9660 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
9661 Safefree(usrprodsc.dsc$a_pointer);
9662 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
9666 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
9670 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
9671 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
9672 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
9673 set_vaxc_errno(retsts);
9674 if (retsts == SS$_NOPRIV) set_errno(EACCES);
9675 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
9676 else set_errno(ENOENT);
9679 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
9684 return FALSE; /* Should never get here */
9686 } /* end of cando_by_name() */
9690 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
9692 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
9694 if (!fstat(fd,(stat_t *) statbufp)) {
9695 if (statbufp == (Stat_t *) &PL_statcache) {
9698 /* Save name for cando by name in VMS format */
9699 cptr = getname(fd, namecache, 1);
9701 /* This should not happen, but just in case */
9703 namecache[0] = '\0';
9705 #ifdef _USE_STD_STAT
9706 memcpy(&statbufp->st_ino, &statbufp->crtl_stat.st_ino, 8);
9708 memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9710 #ifndef _USE_STD_STAT
9711 strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9712 statbufp->st_devnam[63] = 0;
9713 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9716 * The device is only encoded so that Perl_cando can use it to
9717 * look up ACLS. So rmsexpand it to the 255 character version
9718 * and store it in ->st_devnam. rmsexpand needs to be fixed
9719 * for long filenames and symbolic links first. This also seems
9720 * to remove the need for a namecache that could be stale.
9724 # ifdef RTL_USES_UTC
9727 statbufp->st_mtime = _toloc(statbufp->st_mtime);
9728 statbufp->st_atime = _toloc(statbufp->st_atime);
9729 statbufp->st_ctime = _toloc(statbufp->st_ctime);
9734 if (!VMSISH_TIME) { /* Return UTC instead of local time */
9738 statbufp->st_mtime = _toutc(statbufp->st_mtime);
9739 statbufp->st_atime = _toutc(statbufp->st_atime);
9740 statbufp->st_ctime = _toutc(statbufp->st_ctime);
9747 } /* end of flex_fstat() */
9750 #if !defined(__VAX) && __CRTL_VER >= 80200000
9758 #define lstat(_x, _y) stat(_x, _y)
9761 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
9764 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
9766 char fileified[NAM$C_MAXRSS+1];
9767 char temp_fspec[NAM$C_MAXRSS+300];
9769 int saved_errno, saved_vaxc_errno;
9771 if (!fspec) return retval;
9772 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
9773 strcpy(temp_fspec, fspec);
9774 if (statbufp == (Stat_t *) &PL_statcache)
9775 do_tovmsspec(temp_fspec,namecache,0);
9776 if (decc_bug_devnull != 0) {
9777 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
9778 memset(statbufp,0,sizeof *statbufp);
9779 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
9780 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
9781 statbufp->st_uid = 0x00010001;
9782 statbufp->st_gid = 0x0001;
9783 time((time_t *)&statbufp->st_mtime);
9784 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
9789 /* Try for a directory name first. If fspec contains a filename without
9790 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9791 * and sea:[wine.dark]water. exist, we prefer the directory here.
9792 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
9793 * not sea:[wine.dark]., if the latter exists. If the intended target is
9794 * the file with null type, specify this by calling flex_stat() with
9795 * a '.' at the end of fspec.
9797 * If we are in Posix filespec mode, accept the filename as is.
9799 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9800 if (decc_posix_compliant_pathnames == 0) {
9802 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
9803 if (lstat_flag == 0)
9804 retval = stat(fileified,(stat_t *) statbufp);
9806 retval = lstat(fileified,(stat_t *) statbufp);
9807 if (!retval && statbufp == (Stat_t *) &PL_statcache)
9808 strcpy(namecache,fileified);
9811 if (lstat_flag == 0)
9812 retval = stat(temp_fspec,(stat_t *) statbufp);
9814 retval = lstat(temp_fspec,(stat_t *) statbufp);
9816 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9818 if (lstat_flag == 0)
9819 retval = stat(temp_fspec,(stat_t *) statbufp);
9821 retval = lstat(temp_fspec,(stat_t *) statbufp);
9825 #ifdef _USE_STD_STAT
9826 memcpy(&statbufp->st_ino, &statbufp->crtl_stat.st_ino, 8);
9828 memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9830 #ifndef _USE_STD_STAT
9831 strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9832 statbufp->st_devnam[63] = 0;
9833 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9836 * The device is only encoded so that Perl_cando can use it to
9837 * look up ACLS. So rmsexpand it to the 255 character version
9838 * and store it in ->st_devnam. rmsexpand needs to be fixed
9839 * for long filenames and symbolic links first. This also seems
9840 * to remove the need for a namecache that could be stale.
9843 # ifdef RTL_USES_UTC
9846 statbufp->st_mtime = _toloc(statbufp->st_mtime);
9847 statbufp->st_atime = _toloc(statbufp->st_atime);
9848 statbufp->st_ctime = _toloc(statbufp->st_ctime);
9853 if (!VMSISH_TIME) { /* Return UTC instead of local time */
9857 statbufp->st_mtime = _toutc(statbufp->st_mtime);
9858 statbufp->st_atime = _toutc(statbufp->st_atime);
9859 statbufp->st_ctime = _toutc(statbufp->st_ctime);
9863 /* If we were successful, leave errno where we found it */
9864 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
9867 } /* end of flex_stat_int() */
9870 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
9872 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
9874 return flex_stat_int(fspec, statbufp, 0);
9878 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
9880 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
9882 return flex_stat_int(fspec, statbufp, 1);
9887 /*{{{char *my_getlogin()*/
9888 /* VMS cuserid == Unix getlogin, except calling sequence */
9892 static char user[L_cuserid];
9893 return cuserid(user);
9898 /* rmscopy - copy a file using VMS RMS routines
9900 * Copies contents and attributes of spec_in to spec_out, except owner
9901 * and protection information. Name and type of spec_in are used as
9902 * defaults for spec_out. The third parameter specifies whether rmscopy()
9903 * should try to propagate timestamps from the input file to the output file.
9904 * If it is less than 0, no timestamps are preserved. If it is 0, then
9905 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
9906 * propagated to the output file at creation iff the output file specification
9907 * did not contain an explicit name or type, and the revision date is always
9908 * updated at the end of the copy operation. If it is greater than 0, then
9909 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
9910 * other than the revision date should be propagated, and bit 1 indicates
9911 * that the revision date should be propagated.
9913 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
9915 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
9916 * Incorporates, with permission, some code from EZCOPY by Tim Adye
9917 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
9918 * as part of the Perl standard distribution under the terms of the
9919 * GNU General Public License or the Perl Artistic License. Copies
9920 * of each may be found in the Perl standard distribution.
9922 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
9923 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
9925 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
9927 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
9928 rsa[NAM$C_MAXRSS], ubf[32256];
9929 unsigned long int i, sts, sts2;
9930 struct FAB fab_in, fab_out;
9931 struct RAB rab_in, rab_out;
9933 struct XABDAT xabdat;
9934 struct XABFHC xabfhc;
9935 struct XABRDT xabrdt;
9936 struct XABSUM xabsum;
9938 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
9939 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
9940 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9944 fab_in = cc$rms_fab;
9945 fab_in.fab$l_fna = vmsin;
9946 fab_in.fab$b_fns = strlen(vmsin);
9947 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
9948 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
9949 fab_in.fab$l_fop = FAB$M_SQO;
9950 fab_in.fab$l_nam = &nam;
9951 fab_in.fab$l_xab = (void *) &xabdat;
9954 nam.nam$l_rsa = rsa;
9955 nam.nam$b_rss = sizeof(rsa);
9956 nam.nam$l_esa = esa;
9957 nam.nam$b_ess = sizeof (esa);
9958 nam.nam$b_esl = nam.nam$b_rsl = 0;
9959 #ifdef NAM$M_NO_SHORT_UPCASE
9960 if (decc_efs_case_preserve)
9961 nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9964 xabdat = cc$rms_xabdat; /* To get creation date */
9965 xabdat.xab$l_nxt = (void *) &xabfhc;
9967 xabfhc = cc$rms_xabfhc; /* To get record length */
9968 xabfhc.xab$l_nxt = (void *) &xabsum;
9970 xabsum = cc$rms_xabsum; /* To get key and area information */
9972 if (!((sts = sys$open(&fab_in)) & 1)) {
9973 set_vaxc_errno(sts);
9975 case RMS$_FNF: case RMS$_DNF:
9976 set_errno(ENOENT); break;
9978 set_errno(ENOTDIR); break;
9980 set_errno(ENODEV); break;
9982 set_errno(EINVAL); break;
9984 set_errno(EACCES); break;
9992 fab_out.fab$w_ifi = 0;
9993 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
9994 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
9995 fab_out.fab$l_fop = FAB$M_SQO;
9996 fab_out.fab$l_fna = vmsout;
9997 fab_out.fab$b_fns = strlen(vmsout);
9998 fab_out.fab$l_dna = nam.nam$l_name;
9999 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
10001 if (preserve_dates == 0) { /* Act like DCL COPY */
10002 nam.nam$b_nop |= NAM$M_SYNCHK;
10003 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
10004 if (!((sts = sys$parse(&fab_out)) & 1)) {
10005 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10006 set_vaxc_errno(sts);
10009 fab_out.fab$l_xab = (void *) &xabdat;
10010 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10012 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
10013 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
10014 preserve_dates =0; /* bitmask from this point forward */
10016 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10017 if (!((sts = sys$create(&fab_out)) & 1)) {
10018 set_vaxc_errno(sts);
10021 set_errno(ENOENT); break;
10023 set_errno(ENOTDIR); break;
10025 set_errno(ENODEV); break;
10027 set_errno(EINVAL); break;
10029 set_errno(EACCES); break;
10031 set_errno(EVMSERR);
10035 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
10036 if (preserve_dates & 2) {
10037 /* sys$close() will process xabrdt, not xabdat */
10038 xabrdt = cc$rms_xabrdt;
10040 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10042 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10043 * is unsigned long[2], while DECC & VAXC use a struct */
10044 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10046 fab_out.fab$l_xab = (void *) &xabrdt;
10049 rab_in = cc$rms_rab;
10050 rab_in.rab$l_fab = &fab_in;
10051 rab_in.rab$l_rop = RAB$M_BIO;
10052 rab_in.rab$l_ubf = ubf;
10053 rab_in.rab$w_usz = sizeof ubf;
10054 if (!((sts = sys$connect(&rab_in)) & 1)) {
10055 sys$close(&fab_in); sys$close(&fab_out);
10056 set_errno(EVMSERR); set_vaxc_errno(sts);
10060 rab_out = cc$rms_rab;
10061 rab_out.rab$l_fab = &fab_out;
10062 rab_out.rab$l_rbf = ubf;
10063 if (!((sts = sys$connect(&rab_out)) & 1)) {
10064 sys$close(&fab_in); sys$close(&fab_out);
10065 set_errno(EVMSERR); set_vaxc_errno(sts);
10069 while ((sts = sys$read(&rab_in))) { /* always true */
10070 if (sts == RMS$_EOF) break;
10071 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10072 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10073 sys$close(&fab_in); sys$close(&fab_out);
10074 set_errno(EVMSERR); set_vaxc_errno(sts);
10079 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
10080 sys$close(&fab_in); sys$close(&fab_out);
10081 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10083 set_errno(EVMSERR); set_vaxc_errno(sts);
10089 } /* end of rmscopy() */
10091 /* ODS-5 support version */
10093 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10095 char *vmsin, * vmsout, *esa, *esa_out,
10097 unsigned long int i, sts, sts2;
10098 struct FAB fab_in, fab_out;
10099 struct RAB rab_in, rab_out;
10101 struct NAML nam_out;
10102 struct XABDAT xabdat;
10103 struct XABFHC xabfhc;
10104 struct XABRDT xabrdt;
10105 struct XABSUM xabsum;
10107 Newx(vmsin, VMS_MAXRSS, char);
10108 Newx(vmsout, VMS_MAXRSS, char);
10109 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
10110 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10113 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10117 Newx(esa, VMS_MAXRSS, char);
10119 fab_in = cc$rms_fab;
10120 fab_in.fab$l_fna = (char *) -1;
10121 fab_in.fab$b_fns = 0;
10122 nam.naml$l_long_filename = vmsin;
10123 nam.naml$l_long_filename_size = strlen(vmsin);
10124 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10125 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10126 fab_in.fab$l_fop = FAB$M_SQO;
10127 fab_in.fab$l_naml = &nam;
10128 fab_in.fab$l_xab = (void *) &xabdat;
10130 Newx(rsa, VMS_MAXRSS, char);
10131 nam.naml$l_rsa = NULL;
10132 nam.naml$b_rss = 0;
10133 nam.naml$l_long_result = rsa;
10134 nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10135 nam.naml$l_esa = NULL;
10136 nam.naml$b_ess = 0;
10137 nam.naml$l_long_expand = esa;
10138 nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10139 nam.naml$b_esl = nam.naml$b_rsl = 0;
10140 nam.naml$l_long_expand_size = 0;
10141 nam.naml$l_long_result_size = 0;
10142 #ifdef NAM$M_NO_SHORT_UPCASE
10143 if (decc_efs_case_preserve)
10144 nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10147 xabdat = cc$rms_xabdat; /* To get creation date */
10148 xabdat.xab$l_nxt = (void *) &xabfhc;
10150 xabfhc = cc$rms_xabfhc; /* To get record length */
10151 xabfhc.xab$l_nxt = (void *) &xabsum;
10153 xabsum = cc$rms_xabsum; /* To get key and area information */
10155 if (!((sts = sys$open(&fab_in)) & 1)) {
10160 set_vaxc_errno(sts);
10162 case RMS$_FNF: case RMS$_DNF:
10163 set_errno(ENOENT); break;
10165 set_errno(ENOTDIR); break;
10167 set_errno(ENODEV); break;
10169 set_errno(EINVAL); break;
10171 set_errno(EACCES); break;
10173 set_errno(EVMSERR);
10180 fab_out.fab$w_ifi = 0;
10181 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10182 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10183 fab_out.fab$l_fop = FAB$M_SQO;
10184 fab_out.fab$l_naml = &nam_out;
10185 fab_out.fab$l_fna = (char *) -1;
10186 fab_out.fab$b_fns = 0;
10187 nam_out.naml$l_long_filename = vmsout;
10188 nam_out.naml$l_long_filename_size = strlen(vmsout);
10189 fab_out.fab$l_dna = (char *) -1;
10190 fab_out.fab$b_dns = 0;
10191 nam_out.naml$l_long_defname = nam.naml$l_long_name;
10192 nam_out.naml$l_long_defname_size =
10193 nam.naml$l_long_name ?
10194 nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10196 Newx(esa_out, VMS_MAXRSS, char);
10197 nam_out.naml$l_rsa = NULL;
10198 nam_out.naml$b_rss = 0;
10199 nam_out.naml$l_long_result = NULL;
10200 nam_out.naml$l_long_result_alloc = 0;
10201 nam_out.naml$l_esa = NULL;
10202 nam_out.naml$b_ess = 0;
10203 nam_out.naml$l_long_expand = esa_out;
10204 nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10206 if (preserve_dates == 0) { /* Act like DCL COPY */
10207 nam_out.naml$b_nop |= NAM$M_SYNCHK;
10208 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
10209 if (!((sts = sys$parse(&fab_out)) & 1)) {
10215 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10216 set_vaxc_errno(sts);
10219 fab_out.fab$l_xab = (void *) &xabdat;
10220 if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10222 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
10223 preserve_dates =0; /* bitmask from this point forward */
10225 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10226 if (!((sts = sys$create(&fab_out)) & 1)) {
10232 set_vaxc_errno(sts);
10235 set_errno(ENOENT); break;
10237 set_errno(ENOTDIR); break;
10239 set_errno(ENODEV); break;
10241 set_errno(EINVAL); break;
10243 set_errno(EACCES); break;
10245 set_errno(EVMSERR);
10249 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
10250 if (preserve_dates & 2) {
10251 /* sys$close() will process xabrdt, not xabdat */
10252 xabrdt = cc$rms_xabrdt;
10254 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10256 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10257 * is unsigned long[2], while DECC & VAXC use a struct */
10258 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10260 fab_out.fab$l_xab = (void *) &xabrdt;
10263 Newx(ubf, 32256, char);
10264 rab_in = cc$rms_rab;
10265 rab_in.rab$l_fab = &fab_in;
10266 rab_in.rab$l_rop = RAB$M_BIO;
10267 rab_in.rab$l_ubf = ubf;
10268 rab_in.rab$w_usz = 32256;
10269 if (!((sts = sys$connect(&rab_in)) & 1)) {
10270 sys$close(&fab_in); sys$close(&fab_out);
10277 set_errno(EVMSERR); set_vaxc_errno(sts);
10281 rab_out = cc$rms_rab;
10282 rab_out.rab$l_fab = &fab_out;
10283 rab_out.rab$l_rbf = ubf;
10284 if (!((sts = sys$connect(&rab_out)) & 1)) {
10285 sys$close(&fab_in); sys$close(&fab_out);
10292 set_errno(EVMSERR); set_vaxc_errno(sts);
10296 while ((sts = sys$read(&rab_in))) { /* always true */
10297 if (sts == RMS$_EOF) break;
10298 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10299 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10300 sys$close(&fab_in); sys$close(&fab_out);
10307 set_errno(EVMSERR); set_vaxc_errno(sts);
10313 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
10314 sys$close(&fab_in); sys$close(&fab_out);
10315 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10323 set_errno(EVMSERR); set_vaxc_errno(sts);
10335 } /* end of rmscopy() */
10340 /*** The following glue provides 'hooks' to make some of the routines
10341 * from this file available from Perl. These routines are sufficiently
10342 * basic, and are required sufficiently early in the build process,
10343 * that's it's nice to have them available to miniperl as well as the
10344 * full Perl, so they're set up here instead of in an extension. The
10345 * Perl code which handles importation of these names into a given
10346 * package lives in [.VMS]Filespec.pm in @INC.
10350 rmsexpand_fromperl(pTHX_ CV *cv)
10353 char *fspec, *defspec = NULL, *rslt;
10356 if (!items || items > 2)
10357 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10358 fspec = SvPV(ST(0),n_a);
10359 if (!fspec || !*fspec) XSRETURN_UNDEF;
10360 if (items == 2) defspec = SvPV(ST(1),n_a);
10362 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10363 ST(0) = sv_newmortal();
10364 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10369 vmsify_fromperl(pTHX_ CV *cv)
10375 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10376 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10377 ST(0) = sv_newmortal();
10378 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10383 unixify_fromperl(pTHX_ CV *cv)
10389 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10390 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10391 ST(0) = sv_newmortal();
10392 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10397 fileify_fromperl(pTHX_ CV *cv)
10403 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10404 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10405 ST(0) = sv_newmortal();
10406 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10411 pathify_fromperl(pTHX_ CV *cv)
10417 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10418 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10419 ST(0) = sv_newmortal();
10420 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10425 vmspath_fromperl(pTHX_ CV *cv)
10431 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10432 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10433 ST(0) = sv_newmortal();
10434 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10439 unixpath_fromperl(pTHX_ CV *cv)
10445 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10446 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10447 ST(0) = sv_newmortal();
10448 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10453 candelete_fromperl(pTHX_ CV *cv)
10456 char fspec[NAM$C_MAXRSS+1], *fsp;
10461 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10463 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10464 if (SvTYPE(mysv) == SVt_PVGV) {
10465 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10466 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10473 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10474 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10480 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10485 rmscopy_fromperl(pTHX_ CV *cv)
10488 char *inspec, *outspec, *inp, *outp;
10490 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10491 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10492 unsigned long int sts;
10497 if (items < 2 || items > 3)
10498 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10500 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10501 Newx(inspec, VMS_MAXRSS, char);
10502 if (SvTYPE(mysv) == SVt_PVGV) {
10503 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10504 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10512 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10513 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10519 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
10520 Newx(outspec, VMS_MAXRSS, char);
10521 if (SvTYPE(mysv) == SVt_PVGV) {
10522 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
10523 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10532 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
10533 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10540 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
10542 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
10548 /* The mod2fname is limited to shorter filenames by design, so it should
10549 * not be modified to support longer EFS pathnames
10552 mod2fname(pTHX_ CV *cv)
10555 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10556 workbuff[NAM$C_MAXRSS*1 + 1];
10557 int total_namelen = 3, counter, num_entries;
10558 /* ODS-5 ups this, but we want to be consistent, so... */
10559 int max_name_len = 39;
10560 AV *in_array = (AV *)SvRV(ST(0));
10562 num_entries = av_len(in_array);
10564 /* All the names start with PL_. */
10565 strcpy(ultimate_name, "PL_");
10567 /* Clean up our working buffer */
10568 Zero(work_name, sizeof(work_name), char);
10570 /* Run through the entries and build up a working name */
10571 for(counter = 0; counter <= num_entries; counter++) {
10572 /* If it's not the first name then tack on a __ */
10574 strcat(work_name, "__");
10576 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10580 /* Check to see if we actually have to bother...*/
10581 if (strlen(work_name) + 3 <= max_name_len) {
10582 strcat(ultimate_name, work_name);
10584 /* It's too darned big, so we need to go strip. We use the same */
10585 /* algorithm as xsubpp does. First, strip out doubled __ */
10586 char *source, *dest, last;
10589 for (source = work_name; *source; source++) {
10590 if (last == *source && last == '_') {
10596 /* Go put it back */
10597 strcpy(work_name, workbuff);
10598 /* Is it still too big? */
10599 if (strlen(work_name) + 3 > max_name_len) {
10600 /* Strip duplicate letters */
10603 for (source = work_name; *source; source++) {
10604 if (last == toupper(*source)) {
10608 last = toupper(*source);
10610 strcpy(work_name, workbuff);
10613 /* Is it *still* too big? */
10614 if (strlen(work_name) + 3 > max_name_len) {
10615 /* Too bad, we truncate */
10616 work_name[max_name_len - 2] = 0;
10618 strcat(ultimate_name, work_name);
10621 /* Okay, return it */
10622 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10627 hushexit_fromperl(pTHX_ CV *cv)
10632 VMSISH_HUSHED = SvTRUE(ST(0));
10634 ST(0) = boolSV(VMSISH_HUSHED);
10640 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10643 vms_realpath_fromperl(pTHX_ CV *cv)
10646 char *fspec, *rslt_spec, *rslt;
10649 if (!items || items != 1)
10650 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
10652 fspec = SvPV(ST(0),n_a);
10653 if (!fspec || !*fspec) XSRETURN_UNDEF;
10655 Newx(rslt_spec, VMS_MAXRSS + 1, char);
10656 rslt = do_vms_realpath(fspec, rslt_spec);
10657 ST(0) = sv_newmortal();
10659 sv_usepvn(ST(0),rslt,strlen(rslt));
10661 Safefree(rslt_spec);
10666 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10667 int do_vms_case_tolerant(void);
10670 vms_case_tolerant_fromperl(pTHX_ CV *cv)
10673 ST(0) = boolSV(do_vms_case_tolerant());
10679 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
10680 struct interp_intern *dst)
10682 memcpy(dst,src,sizeof(struct interp_intern));
10686 Perl_sys_intern_clear(pTHX)
10691 Perl_sys_intern_init(pTHX)
10693 unsigned int ix = RAND_MAX;
10698 /* fix me later to track running under GNV */
10699 /* this allows some limited testing */
10700 MY_POSIX_EXIT = decc_filename_unix_report;
10703 MY_INV_RAND_MAX = 1./x;
10707 init_os_extras(void)
10710 char* file = __FILE__;
10711 char temp_buff[512];
10712 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
10713 no_translate_barewords = TRUE;
10715 no_translate_barewords = FALSE;
10718 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
10719 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
10720 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
10721 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
10722 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
10723 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
10724 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
10725 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
10726 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
10727 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
10728 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
10730 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
10732 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10733 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
10736 store_pipelocs(aTHX); /* will redo any earlier attempts */
10743 #if __CRTL_VER == 80200000
10744 /* This missed getting in to the DECC SDK for 8.2 */
10745 char *realpath(const char *file_name, char * resolved_name, ...);
10748 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
10749 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
10750 * The perl fallback routine to provide realpath() is not as efficient
10754 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10756 return realpath(filespec, outbuf);
10760 /* External entry points */
10761 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10762 { return do_vms_realpath(filespec, outbuf); }
10764 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10769 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10770 /* case_tolerant */
10772 /*{{{int do_vms_case_tolerant(void)*/
10773 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
10774 * controlled by a process setting.
10776 int do_vms_case_tolerant(void)
10778 return vms_process_case_tolerant;
10781 /* External entry points */
10782 int Perl_vms_case_tolerant(void)
10783 { return do_vms_case_tolerant(); }
10785 int Perl_vms_case_tolerant(void)
10786 { return vms_process_case_tolerant; }
10790 /* Start of DECC RTL Feature handling */
10792 static int sys_trnlnm
10793 (const char * logname,
10797 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
10798 const unsigned long attr = LNM$M_CASE_BLIND;
10799 struct dsc$descriptor_s name_dsc;
10801 unsigned short result;
10802 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
10805 name_dsc.dsc$w_length = strlen(logname);
10806 name_dsc.dsc$a_pointer = (char *)logname;
10807 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10808 name_dsc.dsc$b_class = DSC$K_CLASS_S;
10810 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
10812 if ($VMS_STATUS_SUCCESS(status)) {
10814 /* Null terminate and return the string */
10815 /*--------------------------------------*/
10822 static int sys_crelnm
10823 (const char * logname,
10824 const char * value)
10827 const char * proc_table = "LNM$PROCESS_TABLE";
10828 struct dsc$descriptor_s proc_table_dsc;
10829 struct dsc$descriptor_s logname_dsc;
10830 struct itmlst_3 item_list[2];
10832 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
10833 proc_table_dsc.dsc$w_length = strlen(proc_table);
10834 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10835 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
10837 logname_dsc.dsc$a_pointer = (char *) logname;
10838 logname_dsc.dsc$w_length = strlen(logname);
10839 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10840 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
10842 item_list[0].buflen = strlen(value);
10843 item_list[0].itmcode = LNM$_STRING;
10844 item_list[0].bufadr = (char *)value;
10845 item_list[0].retlen = NULL;
10847 item_list[1].buflen = 0;
10848 item_list[1].itmcode = 0;
10850 ret_val = sys$crelnm
10852 (const struct dsc$descriptor_s *)&proc_table_dsc,
10853 (const struct dsc$descriptor_s *)&logname_dsc,
10855 (const struct item_list_3 *) item_list);
10861 /* C RTL Feature settings */
10863 static int set_features
10864 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
10865 int (* cli_routine)(void), /* Not documented */
10866 void *image_info) /* Not documented */
10873 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
10874 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
10875 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
10876 unsigned long case_perm;
10877 unsigned long case_image;
10880 /* hacks to see if known bugs are still present for testing */
10882 /* Readdir is returning filenames in VMS syntax always */
10883 decc_bug_readdir_efs1 = 1;
10884 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
10885 if ($VMS_STATUS_SUCCESS(status)) {
10886 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10887 decc_bug_readdir_efs1 = 1;
10889 decc_bug_readdir_efs1 = 0;
10892 /* PCP mode requires creating /dev/null special device file */
10893 decc_bug_devnull = 0;
10894 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
10895 if ($VMS_STATUS_SUCCESS(status)) {
10896 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10897 decc_bug_devnull = 1;
10900 /* fgetname returning a VMS name in UNIX mode */
10901 decc_bug_fgetname = 1;
10902 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
10903 if ($VMS_STATUS_SUCCESS(status)) {
10904 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10905 decc_bug_fgetname = 1;
10907 decc_bug_fgetname = 0;
10910 /* UNIX directory names with no paths are broken in a lot of places */
10911 decc_dir_barename = 1;
10912 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
10913 if ($VMS_STATUS_SUCCESS(status)) {
10914 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10915 decc_dir_barename = 1;
10917 decc_dir_barename = 0;
10920 #if __CRTL_VER >= 70300000 && !defined(__VAX)
10921 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
10923 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
10924 if (decc_disable_to_vms_logname_translation < 0)
10925 decc_disable_to_vms_logname_translation = 0;
10928 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
10930 decc_efs_case_preserve = decc$feature_get_value(s, 1);
10931 if (decc_efs_case_preserve < 0)
10932 decc_efs_case_preserve = 0;
10935 s = decc$feature_get_index("DECC$EFS_CHARSET");
10937 decc_efs_charset = decc$feature_get_value(s, 1);
10938 if (decc_efs_charset < 0)
10939 decc_efs_charset = 0;
10942 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
10944 decc_filename_unix_report = decc$feature_get_value(s, 1);
10945 if (decc_filename_unix_report > 0)
10946 decc_filename_unix_report = 1;
10948 decc_filename_unix_report = 0;
10951 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
10953 decc_filename_unix_only = decc$feature_get_value(s, 1);
10954 if (decc_filename_unix_only > 0) {
10955 decc_filename_unix_only = 1;
10958 decc_filename_unix_only = 0;
10962 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
10964 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
10965 if (decc_filename_unix_no_version < 0)
10966 decc_filename_unix_no_version = 0;
10969 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
10971 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
10972 if (decc_readdir_dropdotnotype < 0)
10973 decc_readdir_dropdotnotype = 0;
10976 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
10977 if ($VMS_STATUS_SUCCESS(status)) {
10978 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
10980 dflt = decc$feature_get_value(s, 4);
10982 decc_disable_posix_root = decc$feature_get_value(s, 1);
10983 if (decc_disable_posix_root <= 0) {
10984 decc$feature_set_value(s, 1, 1);
10985 decc_disable_posix_root = 1;
10989 /* Traditionally Perl assumes this is off */
10990 decc_disable_posix_root = 1;
10991 decc$feature_set_value(s, 1, 1);
10996 #if __CRTL_VER >= 80200000
10997 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
10999 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11000 if (decc_posix_compliant_pathnames < 0)
11001 decc_posix_compliant_pathnames = 0;
11002 if (decc_posix_compliant_pathnames > 4)
11003 decc_posix_compliant_pathnames = 0;
11008 status = sys_trnlnm
11009 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11010 if ($VMS_STATUS_SUCCESS(status)) {
11011 val_str[0] = _toupper(val_str[0]);
11012 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11013 decc_disable_to_vms_logname_translation = 1;
11018 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11019 if ($VMS_STATUS_SUCCESS(status)) {
11020 val_str[0] = _toupper(val_str[0]);
11021 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11022 decc_efs_case_preserve = 1;
11027 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11028 if ($VMS_STATUS_SUCCESS(status)) {
11029 val_str[0] = _toupper(val_str[0]);
11030 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11031 decc_filename_unix_report = 1;
11034 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11035 if ($VMS_STATUS_SUCCESS(status)) {
11036 val_str[0] = _toupper(val_str[0]);
11037 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11038 decc_filename_unix_only = 1;
11039 decc_filename_unix_report = 1;
11042 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11043 if ($VMS_STATUS_SUCCESS(status)) {
11044 val_str[0] = _toupper(val_str[0]);
11045 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11046 decc_filename_unix_no_version = 1;
11049 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11050 if ($VMS_STATUS_SUCCESS(status)) {
11051 val_str[0] = _toupper(val_str[0]);
11052 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11053 decc_readdir_dropdotnotype = 1;
11058 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11060 /* Report true case tolerance */
11061 /*----------------------------*/
11062 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11063 if (!$VMS_STATUS_SUCCESS(status))
11064 case_perm = PPROP$K_CASE_BLIND;
11065 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11066 if (!$VMS_STATUS_SUCCESS(status))
11067 case_image = PPROP$K_CASE_BLIND;
11068 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11069 (case_image == PPROP$K_CASE_SENSITIVE))
11070 vms_process_case_tolerant = 0;
11075 /* CRTL can be initialized past this point, but not before. */
11076 /* DECC$CRTL_INIT(); */
11082 /* DECC dependent attributes */
11083 #if __DECC_VER < 60560002
11085 #define not_executable
11087 #define relative ,rel
11088 #define not_executable ,noexe
11091 #pragma extern_model save
11092 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11094 const __align (LONGWORD) int spare[8] = {0};
11095 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11098 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11099 nowrt,noshr relative not_executable
11101 const long vms_cc_features = (const long)set_features;
11104 ** Force a reference to LIB$INITIALIZE to ensure it
11105 ** exists in the image.
11107 int lib$initialize(void);
11109 #pragma extern_model strict_refdef
11111 int lib_init_ref = (int) lib$initialize;
11114 #pragma extern_model restore