perl5.git.perl.org Git - perl5.git/blame_incremental

... / ...

Commit	Line	Data
	1	/* vms.c
	2	*
	3	* VMS-specific routines for perl5
	4	* Version: 5.7.0
	5	*
	6	* August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
	7	* and Perl_cando by Craig Berry
	8	* 29-Aug-2000 Charles Lane's piping improvements rolled in
	9	* 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
	10	*/
	11
	12	#include <accdef.h>
	13	#include <acedef.h>
	14	#include <acldef.h>
	15	#include <armdef.h>
	16	#include <atrdef.h>
	17	#include <chpdef.h>
	18	#include <clidef.h>
	19	#include <climsgdef.h>
	20	#include <descrip.h>
	21	#include <devdef.h>
	22	#include <dvidef.h>
	23	#include <fibdef.h>
	24	#include <float.h>
	25	#include <fscndef.h>
	26	#include <iodef.h>
	27	#include <jpidef.h>
	28	#include <kgbdef.h>
	29	#include <libclidef.h>
	30	#include <libdef.h>
	31	#include <lib$routines.h>
	32	#include <lnmdef.h>
	33	#include <msgdef.h>
	34	#include <prvdef.h>
	35	#include <psldef.h>
	36	#include <rms.h>
	37	#include <shrdef.h>
	38	#include <ssdef.h>
	39	#include <starlet.h>
	40	#include <strdef.h>
	41	#include <str$routines.h>
	42	#include <syidef.h>
	43	#include <uaidef.h>
	44	#include <uicdef.h>
	45
	46	/* Older versions of ssdef.h don't have these */
	47	#ifndef SS$_INVFILFOROP
	48	# define SS$_INVFILFOROP 3930
	49	#endif
	50	#ifndef SS$_NOSUCHOBJECT
	51	# define SS$_NOSUCHOBJECT 2696
	52	#endif
	53
	54	/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
	55	#define PERLIO_NOT_STDIO 0
	56
	57	/* Don't replace system definitions of vfork, getenv, and stat,
	58	* code below needs to get to the underlying CRTL routines. */
	59	#define DONT_MASK_RTL_CALLS
	60	#include "EXTERN.h"
	61	#include "perl.h"
	62	#include "XSUB.h"
	63	/* Anticipating future expansion in lexical warnings . . . */
	64	#ifndef WARN_INTERNAL
	65	# define WARN_INTERNAL WARN_MISC
	66	#endif
	67
	68	#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
	69	# define RTL_USES_UTC 1
	70	#endif
	71
	72
	73	/* gcc's header files don't #define direct access macros
	74	* corresponding to VAXC's variant structs */
	75	#ifdef __GNUC__
	76	# define uic$v_format uic$r_uic_form.uic$v_format
	77	# define uic$v_group uic$r_uic_form.uic$v_group
	78	# define uic$v_member uic$r_uic_form.uic$v_member
	79	# define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
	80	# define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
	81	# define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
	82	# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
	83	#endif
	84
	85	#if defined(NEED_AN_H_ERRNO)
	86	dEXT int h_errno;
	87	#endif
	88
	89	struct itmlst_3 {
	90	unsigned short int buflen;
	91	unsigned short int itmcode;
	92	void *bufadr;
	93	unsigned short int *retlen;
	94	};
	95
	96	#define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
	97	#define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
	98	#define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
	99	#define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
	100	#define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
	101	#define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
	102	#define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
	103	#define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
	104	#define getredirection(a,b) mp_getredirection(aTHX_ a,b)
	105
	106	/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
	107	#define PERL_LNM_MAX_ALLOWED_INDEX 127
	108
	109	static char __mystrtolower(char str)
	110	{
	111	if (str) for (; str; ++str) str= tolower(*str);
	112	return str;
	113	}
	114
	115	static struct dsc$descriptor_s fildevdsc =
	116	{ 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
	117	static struct dsc$descriptor_s crtlenvdsc =
	118	{ 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
	119	static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
	120	static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
	121	static struct dsc$descriptor_s **env_tables = defenv;
	122	static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
	123
	124	/* True if we shouldn't treat barewords as logicals during directory */
	125	/* munching */
	126	static int no_translate_barewords;
	127
	128	/* Temp for subprocess commands */
	129	static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
	130
	131	#ifndef RTL_USES_UTC
	132	static int tz_updated = 1;
	133	#endif
	134
	135	/{{{int vmstrnenv(const char lnm, char eqv, unsigned long int idx, struct dsc$descriptor_s tabvec, unsigned long int flags) /
	136	int
	137	Perl_vmstrnenv(const char lnm, char eqv, unsigned long int idx,
	138	struct dsc$descriptor_s **tabvec, unsigned long int flags)
	139	{
	140	char uplnm[LNM$C_NAMLENGTH+1], cp1, cp2;
	141	unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
	142	unsigned long int retsts, attr = LNM$M_CASE_BLIND;
	143	unsigned char acmode;
	144	struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
	145	tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
	146	struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
	147	{LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
	148	{0, 0, 0, 0}};
	149	$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
	150	#if defined(PERL_IMPLICIT_CONTEXT)
	151	pTHX = NULL;
	152	# if defined(USE_5005THREADS)
	153	/* We jump through these hoops because we can be called at */
	154	/* platform-specific initialization time, which is before anything is */
	155	/* set up--we can't even do a plain dTHX since that relies on the */
	156	/* interpreter structure to be initialized */
	157	if (PL_curinterp) {
	158	aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
	159	} else {
	160	aTHX = NULL;
	161	}
	162	# else
	163	if (PL_curinterp) {
	164	aTHX = PERL_GET_INTERP;
	165	} else {
	166	aTHX = NULL;
	167	}
	168
	169	# endif
	170	#endif
	171
	172	if (!lnm \|\| !eqv \|\| idx > PERL_LNM_MAX_ALLOWED_INDEX) {
	173	set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
	174	}
	175	for (cp1 = (char )lnm, cp2 = uplnm; cp1; cp1++, cp2++) {
	176	cp2 = _toupper(cp1);
	177	if (cp1 - lnm > LNM$C_NAMLENGTH) {
	178	set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
	179	return 0;
	180	}
	181	}
	182	lnmdsc.dsc$w_length = cp1 - lnm;
	183	lnmdsc.dsc$a_pointer = uplnm;
	184	uplnm[lnmdsc.dsc$w_length] = '\0';
	185	secure = flags & PERL__TRNENV_SECURE;
	186	acmode = secure ? PSL$C_EXEC : PSL$C_USER;
	187	if (!tabvec \|\| !*tabvec) tabvec = env_tables;
	188
	189	for (curtab = 0; tabvec[curtab]; curtab++) {
	190	if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
	191	if (!ivenv && !secure) {
	192	char eq, end;
	193	int i;
	194	if (!environ) {
	195	ivenv = 1;
	196	Perl_warn(aTHX_ "Can't read CRTL environ\n");
	197	continue;
	198	}
	199	retsts = SS$_NOLOGNAM;
	200	for (i = 0; environ[i]; i++) {
	201	if ((eq = strchr(environ[i],'=')) &&
	202	!strncmp(environ[i],uplnm,eq - environ[i])) {
	203	eq++;
	204	for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
	205	if (!eqvlen) continue;
	206	retsts = SS$_NORMAL;
	207	break;
	208	}
	209	}
	210	if (retsts != SS$_NOLOGNAM) break;
	211	}
	212	}
	213	else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
	214	!str$case_blind_compare(&tmpdsc,&clisym)) {
	215	if (!ivsym && !secure) {
	216	unsigned short int deflen = LNM$C_NAMLENGTH;
	217	struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
	218	/* dynamic dsc to accomodate possible long value */
	219	_ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
	220	retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
	221	if (retsts & 1) {
	222	if (eqvlen > 1024) {
	223	set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
	224	eqvlen = 1024;
	225	/* Special hack--we might be called before the interpreter's */
	226	/* fully initialized, in which case either thr or PL_curcop */
	227	/* might be bogus. We have to check, since ckWARN needs them */
	228	/* both to be valid if running threaded */
	229	#if defined(USE_5005THREADS)
	230	if (thr && PL_curcop) {
	231	#endif
	232	if (ckWARN(WARN_MISC)) {
	233	Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
	234	}
	235	#if defined(USE_5005THREADS)
	236	} else {
	237	Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
	238	}
	239	#endif
	240
	241	}
	242	strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
	243	}
	244	_ckvmssts(lib$sfree1_dd(&eqvdsc));
	245	if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
	246	if (retsts == LIB$_NOSUCHSYM) continue;
	247	break;
	248	}
	249	}
	250	else if (!ivlnm) {
	251	retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
	252	if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
	253	if (retsts == SS$_NOLOGNAM) continue;
	254	/* PPFs have a prefix */
	255	if (
	256	#if INTSIZE == 4
	257	((int )uplnm) == ((int )"SYS$") &&
	258	#endif
	259	eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
	260	( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) \|\|
	261	(uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) \|\|
	262	(uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) \|\|
	263	(uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
	264	memcpy(eqv,eqv+4,eqvlen-4);
	265	eqvlen -= 4;
	266	}
	267	break;
	268	}
	269	}
	270	if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
	271	else if (retsts == LIB$_NOSUCHSYM \|\| retsts == LIB$_INVSYMNAM \|\|
	272	retsts == SS$_IVLOGNAM \|\| retsts == SS$_IVLOGTAB \|\|
	273	retsts == SS$_NOLOGNAM) {
	274	set_errno(EINVAL); set_vaxc_errno(retsts);
	275	}
	276	else _ckvmssts(retsts);
	277	return 0;
	278	} /* end of vmstrnenv */
	279	/}}}/
	280
	281	/{{{ int my_trnlnm(const char lnm, char eqv, unsigned long int idx)/
	282	/* Define as a function so we can access statics. */
	283	int Perl_my_trnlnm(pTHX_ const char lnm, char eqv, unsigned long int idx)
	284	{
	285	return vmstrnenv(lnm,eqv,idx,fildev,
	286	#ifdef SECURE_INTERNAL_GETENV
	287	(PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
	288	#else
	289	0
	290	#endif
	291	);
	292	}
	293	/}}}/
	294
	295	/* my_getenv
	296	* Note: Uses Perl temp to store result so char * can be returned to
	297	* caller; this pointer will be invalidated at next Perl statement
	298	* transition.
	299	* We define this as a function rather than a macro in terms of my_getenv_len()
	300	* so that it'll work when PL_curinterp is undefined (and we therefore can't
	301	* allocate SVs).
	302	*/
	303	/{{{ char my_getenv(const char lnm, bool sys)/
	304	char *
	305	Perl_my_getenv(pTHX_ const char *lnm, bool sys)
	306	{
	307	static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
	308	char uplnm[LNM$C_NAMLENGTH+1], cp1, cp2, *eqv;
	309	unsigned long int idx = 0;
	310	int trnsuccess, success, secure, saverr, savvmserr;
	311	SV *tmpsv;
	312
	313	if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
	314	/* Set up a temporary buffer for the return value; Perl will
	315	* clean it up at the next statement transition */
	316	tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
	317	if (!tmpsv) return NULL;
	318	eqv = SvPVX(tmpsv);
	319	}
	320	else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
	321	for (cp1 = (char ) lnm, cp2 = eqv; cp1; cp1++,cp2++) cp2 = _toupper(cp1);
	322	if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
	323	getcwd(eqv,LNM$C_NAMLENGTH);
	324	return eqv;
	325	}
	326	else {
	327	if ((cp2 = strchr(lnm,';')) != NULL) {
	328	strcpy(uplnm,lnm);
	329	uplnm[cp2-lnm] = '\0';
	330	idx = strtoul(cp2+1,NULL,0);
	331	lnm = uplnm;
	332	}
	333	/* Impose security constraints only if tainting */
	334	if (sys) {
	335	/* Impose security constraints only if tainting */
	336	secure = PL_curinterp ? PL_tainting : will_taint;
	337	saverr = errno; savvmserr = vaxc$errno;
	338	}
	339	else secure = 0;
	340	success = vmstrnenv(lnm,eqv,idx,
	341	secure ? fildev : NULL,
	342	#ifdef SECURE_INTERNAL_GETENV
	343	secure ? PERL__TRNENV_SECURE : 0
	344	#else
	345	0
	346	#endif
	347	);
	348	/* Discard NOLOGNAM on internal calls since we're often looking
	349	* for an optional name, and this "error" often shows up as the
	350	* (bogus) exit status for a die() call later on. */
	351	if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
	352	return success ? eqv : Nullch;
	353	}
	354
	355	} /* end of my_getenv() */
	356	/}}}/
	357
	358
	359	/{{{ SV my_getenv_len(const char lnm, bool sys)/
	360	char *
	361	Perl_my_getenv_len(pTHX_ const char lnm, unsigned long len, bool sys)
	362	{
	363	char buf, cp1, *cp2;
	364	unsigned long idx = 0;
	365	static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
	366	int secure, saverr, savvmserr;
	367	SV *tmpsv;
	368
	369	if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
	370	/* Set up a temporary buffer for the return value; Perl will
	371	* clean it up at the next statement transition */
	372	tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
	373	if (!tmpsv) return NULL;
	374	buf = SvPVX(tmpsv);
	375	}
	376	else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
	377	for (cp1 = (char )lnm, cp2 = buf; cp1; cp1++,cp2++) cp2 = _toupper(cp1);
	378	if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
	379	getcwd(buf,LNM$C_NAMLENGTH);
	380	*len = strlen(buf);
	381	return buf;
	382	}
	383	else {
	384	if ((cp2 = strchr(lnm,';')) != NULL) {
	385	strcpy(buf,lnm);
	386	buf[cp2-lnm] = '\0';
	387	idx = strtoul(cp2+1,NULL,0);
	388	lnm = buf;
	389	}
	390	if (sys) {
	391	/* Impose security constraints only if tainting */
	392	secure = PL_curinterp ? PL_tainting : will_taint;
	393	saverr = errno; savvmserr = vaxc$errno;
	394	}
	395	else secure = 0;
	396	*len = vmstrnenv(lnm,buf,idx,
	397	secure ? fildev : NULL,
	398	#ifdef SECURE_INTERNAL_GETENV
	399	secure ? PERL__TRNENV_SECURE : 0
	400	#else
	401	0
	402	#endif
	403	);
	404	/* Discard NOLOGNAM on internal calls since we're often looking
	405	* for an optional name, and this "error" often shows up as the
	406	* (bogus) exit status for a die() call later on. */
	407	if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
	408	return *len ? buf : Nullch;
	409	}
	410
	411	} /* end of my_getenv_len() */
	412	/}}}/
	413
	414	static void create_mbx(pTHX_ unsigned short int , struct dsc$descriptor_s );
	415
	416	static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
	417
	418	/{{{ void prime_env_iter() /
	419	void
	420	prime_env_iter(void)
	421	/* Fill the %ENV associative array with all logical names we can
	422	* find, in preparation for iterating over it.
	423	*/
	424	{
	425	static int primed = 0;
	426	HV seenhv = NULL, envhv;
	427	SV *sv = NULL;
	428	char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
	429	unsigned short int chan;
	430	#ifndef CLI$M_TRUSTED
	431	# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
	432	#endif
	433	unsigned long int defflags = CLI$M_NOWAIT \| CLI$M_NOKEYPAD \| CLI$M_TRUSTED;
	434	unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
	435	long int i;
	436	bool have_sym = FALSE, have_lnm = FALSE;
	437	struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
	438	$DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
	439	$DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
	440	$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
	441	$DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
	442	#if defined(PERL_IMPLICIT_CONTEXT)
	443	pTHX;
	444	#endif
	445	#if defined(USE_5005THREADS) \|\| defined(USE_ITHREADS)
	446	static perl_mutex primenv_mutex;
	447	MUTEX_INIT(&primenv_mutex);
	448	#endif
	449
	450	#if defined(PERL_IMPLICIT_CONTEXT)
	451	/* We jump through these hoops because we can be called at */
	452	/* platform-specific initialization time, which is before anything is */
	453	/* set up--we can't even do a plain dTHX since that relies on the */
	454	/* interpreter structure to be initialized */
	455	#if defined(USE_5005THREADS)
	456	if (PL_curinterp) {
	457	aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
	458	} else {
	459	aTHX = NULL;
	460	}
	461	#else
	462	if (PL_curinterp) {
	463	aTHX = PERL_GET_INTERP;
	464	} else {
	465	aTHX = NULL;
	466	}
	467	#endif
	468	#endif
	469
	470	if (primed \|\| !PL_envgv) return;
	471	MUTEX_LOCK(&primenv_mutex);
	472	if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
	473	envhv = GvHVn(PL_envgv);
	474	/* Perform a dummy fetch as an lval to insure that the hash table is
	475	* set up. Otherwise, the hv_store() will turn into a nullop. */
	476	(void) hv_fetch(envhv,"DEFAULT",7,TRUE);
	477
	478	for (i = 0; env_tables[i]; i++) {
	479	if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
	480	!str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
	481	if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
	482	}
	483	if (have_sym \|\| have_lnm) {
	484	long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
	485	_ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
	486	_ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
	487	_ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
	488	}
	489
	490	for (i--; i >= 0; i--) {
	491	if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
	492	char *start;
	493	int j;
	494	for (j = 0; environ[j]; j++) {
	495	if (!(start = strchr(environ[j],'='))) {
	496	if (ckWARN(WARN_INTERNAL))
	497	Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
	498	}
	499	else {
	500	start++;
	501	sv = newSVpv(start,0);
	502	SvTAINTED_on(sv);
	503	(void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
	504	}
	505	}
	506	continue;
	507	}
	508	else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
	509	!str$case_blind_compare(&tmpdsc,&clisym)) {
	510	strcpy(cmd,"Show Symbol/Global *");
	511	cmddsc.dsc$w_length = 20;
	512	if (env_tables[i]->dsc$w_length == 12 &&
	513	(tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
	514	!str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
	515	flags = defflags \| CLI$M_NOLOGNAM;
	516	}
	517	else {
	518	strcpy(cmd,"Show Logical *");
	519	if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
	520	strcat(cmd," /Table=");
	521	strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
	522	cmddsc.dsc$w_length = strlen(cmd);
	523	}
	524	else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
	525	flags = defflags \| CLI$M_NOCLISYM;
	526	}
	527
	528	/* Create a new subprocess to execute each command, to exclude the
	529	* remote possibility that someone could subvert a mbx or file used
	530	* to write multiple commands to a single subprocess.
	531	*/
	532	do {
	533	retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
	534	0,&riseandshine,0,0,&clidsc,&clitabdsc);
	535	flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
	536	defflags &= ~CLI$M_TRUSTED;
	537	} while (retsts == LIB$_INVARG && (flags \| CLI$M_TRUSTED));
	538	_ckvmssts(retsts);
	539	if (!buf) New(1322,buf,mbxbufsiz + 1,char);
	540	if (seenhv) SvREFCNT_dec(seenhv);
	541	seenhv = newHV();
	542	while (1) {
	543	char cp1, cp2, *key;
	544	unsigned long int sts, iosb[2], retlen, keylen;
	545	register U32 hash;
	546
	547	sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
	548	if (sts & 1) sts = iosb[0] & 0xffff;
	549	if (sts == SS$_ENDOFFILE) {
	550	int wakect = 0;
	551	while (substs == 0) { sys$hiber(); wakect++;}
	552	if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
	553	_ckvmssts(substs);
	554	break;
	555	}
	556	_ckvmssts(sts);
	557	retlen = iosb[0] >> 16;
	558	if (!retlen) continue; /* blank line */
	559	buf[retlen] = '\0';
	560	if (iosb[1] != subpid) {
	561	if (iosb[1]) {
	562	Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
	563	}
	564	continue;
	565	}
	566	if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
	567	Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
	568
	569	for (cp1 = buf; cp1 && isspace(cp1); cp1++) ;
	570	if (cp1 == '(' \|\| / Logical name table name */
	571	cp1 == '=' / Next eqv of searchlist */) continue;
	572	if (*cp1 == '"') cp1++;
	573	for (cp2 = cp1; cp2 && cp2 != '"' && *cp2 != ' '; cp2++) ;
	574	key = cp1; keylen = cp2 - cp1;
	575	if (keylen && hv_exists(seenhv,key,keylen)) continue;
	576	while (cp2 && cp2 != '=') cp2++;
	577	while (cp2 && cp2 == '=') cp2++;
	578	while (cp2 && cp2 == ' ') cp2++;
	579	if (cp2 == '"') { / String translation; may embed "" */
	580	for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
	581	cp2++; cp1--; /* Skip "" surrounding translation */
	582	}
	583	else { /* Numeric translation */
	584	for (cp1 = cp2; cp1 && cp1 != ' '; cp1++) ;
	585	cp1--; /* stop on last non-space char */
	586	}
	587	if ((!keylen \|\| (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
	588	Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: \|%s\|",buf);
	589	continue;
	590	}
	591	PERL_HASH(hash,key,keylen);
	592	sv = newSVpvn(cp2,cp1 - cp2 + 1);
	593	SvTAINTED_on(sv);
	594	hv_store(envhv,key,keylen,sv,hash);
	595	hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
	596	}
	597	if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
	598	/* get the PPFs for this process, not the subprocess */
	599	char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
	600	char eqv[LNM$C_NAMLENGTH+1];
	601	int trnlen, i;
	602	for (i = 0; ppfs[i]; i++) {
	603	trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
	604	sv = newSVpv(eqv,trnlen);
	605	SvTAINTED_on(sv);
	606	hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
	607	}
	608	}
	609	}
	610	primed = 1;
	611	if (have_sym \|\| have_lnm) _ckvmssts(sys$dassgn(chan));
	612	if (buf) Safefree(buf);
	613	if (seenhv) SvREFCNT_dec(seenhv);
	614	MUTEX_UNLOCK(&primenv_mutex);
	615	return;
	616
	617	} /* end of prime_env_iter */
	618	/}}}/
	619
	620
	621	/{{{ int vmssetenv(char lnm, char eqv)/
	622	/* Define or delete an element in the same "environment" as
	623	* vmstrnenv(). If an element is to be deleted, it's removed from
	624	* the first place it's found. If it's to be set, it's set in the
	625	* place designated by the first element of the table vector.
	626	* Like setenv() returns 0 for success, non-zero on error.
	627	*/
	628	int
	629	Perl_vmssetenv(pTHX_ char lnm, char eqv, struct dsc$descriptor_s **tabvec)
	630	{
	631	char uplnm[LNM$C_NAMLENGTH], cp1, cp2;
	632	unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
	633	unsigned long int retsts, usermode = PSL$C_USER;
	634	struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
	635	eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
	636	tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
	637	$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
	638	$DESCRIPTOR(local,"_LOCAL");
	639
	640	for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
	641	cp2 = _toupper(cp1);
	642	if (cp1 - lnm > LNM$C_NAMLENGTH) {
	643	set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
	644	return SS$_IVLOGNAM;
	645	}
	646	}
	647	lnmdsc.dsc$w_length = cp1 - lnm;
	648	if (!tabvec \|\| !*tabvec) tabvec = env_tables;
	649
	650	if (!eqv) { /* we're deleting n element */
	651	for (curtab = 0; tabvec[curtab]; curtab++) {
	652	if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
	653	int i;
	654	for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
	655	if ((cp1 = strchr(environ[i],'=')) &&
	656	!strncmp(environ[i],lnm,cp1 - environ[i])) {
	657	#ifdef HAS_SETENV
	658	return setenv(lnm,"",1) ? vaxc$errno : 0;
	659	}
	660	}
	661	ivenv = 1; retsts = SS$_NOLOGNAM;
	662	#else
	663	if (ckWARN(WARN_INTERNAL))
	664	Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
	665	ivenv = 1; retsts = SS$_NOSUCHPGM;
	666	break;
	667	}
	668	}
	669	#endif
	670	}
	671	else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
	672	!str$case_blind_compare(&tmpdsc,&clisym)) {
	673	unsigned int symtype;
	674	if (tabvec[curtab]->dsc$w_length == 12 &&
	675	(tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
	676	!str$case_blind_compare(&tmpdsc,&local))
	677	symtype = LIB$K_CLI_LOCAL_SYM;
	678	else symtype = LIB$K_CLI_GLOBAL_SYM;
	679	retsts = lib$delete_symbol(&lnmdsc,&symtype);
	680	if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
	681	if (retsts == LIB$_NOSUCHSYM) continue;
	682	break;
	683	}
	684	else if (!ivlnm) {
	685	retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
	686	if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
	687	if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
	688	retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
	689	if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
	690	}
	691	}
	692	}
	693	else { /* we're defining a value */
	694	if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
	695	#ifdef HAS_SETENV
	696	return setenv(lnm,eqv,1) ? vaxc$errno : 0;
	697	#else
	698	if (ckWARN(WARN_INTERNAL))
	699	Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
	700	retsts = SS$_NOSUCHPGM;
	701	#endif
	702	}
	703	else {
	704	eqvdsc.dsc$a_pointer = eqv;
	705	eqvdsc.dsc$w_length = strlen(eqv);
	706	if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
	707	!str$case_blind_compare(&tmpdsc,&clisym)) {
	708	unsigned int symtype;
	709	if (tabvec[0]->dsc$w_length == 12 &&
	710	(tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
	711	!str$case_blind_compare(&tmpdsc,&local))
	712	symtype = LIB$K_CLI_LOCAL_SYM;
	713	else symtype = LIB$K_CLI_GLOBAL_SYM;
	714	retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
	715	}
	716	else {
	717	if (!*eqv) eqvdsc.dsc$w_length = 1;
	718	if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
	719	eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
	720	if (ckWARN(WARN_MISC)) {
	721	Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
	722	}
	723	}
	724	retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
	725	}
	726	}
	727	}
	728	if (!(retsts & 1)) {
	729	switch (retsts) {
	730	case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
	731	case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
	732	set_errno(EVMSERR); break;
	733	case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
	734	case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
	735	set_errno(EINVAL); break;
	736	case SS$_NOPRIV:
	737	set_errno(EACCES);
	738	default:
	739	_ckvmssts(retsts);
	740	set_errno(EVMSERR);
	741	}
	742	set_vaxc_errno(retsts);
	743	return (int) retsts \|\| 44; /* retsts should never be 0, but just in case */
	744	}
	745	else {
	746	/* We reset error values on success because Perl does an hv_fetch()
	747	* before each hv_store(), and if the thing we're setting didn't
	748	* previously exist, we've got a leftover error message. (Of course,
	749	* this fails in the face of
	750	* $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
	751	* in that the error reported in $! isn't spurious,
	752	* but it's right more often than not.)
	753	*/
	754	set_errno(0); set_vaxc_errno(retsts);
	755	return 0;
	756	}
	757
	758	} /* end of vmssetenv() */
	759	/}}}/
	760
	761	/{{{ void my_setenv(char lnm, char eqv)/
	762	/* This has to be a function since there's a prototype for it in proto.h */
	763	void
	764	Perl_my_setenv(pTHX_ char lnm,char eqv)
	765	{
	766	if (lnm && *lnm) {
	767	int len = strlen(lnm);
	768	if (len == 7) {
	769	char uplnm[8];
	770	int i;
	771	for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
	772	if (!strcmp(uplnm,"DEFAULT")) {
	773	if (eqv && *eqv) chdir(eqv);
	774	return;
	775	}
	776	}
	777	#ifndef RTL_USES_UTC
	778	if (len == 6 \|\| len == 2) {
	779	char uplnm[7];
	780	int i;
	781	for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
	782	uplnm[len] = '\0';
	783	if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
	784	if (!strcmp(uplnm,"TZ")) tz_updated = 1;
	785	}
	786	#endif
	787	}
	788	(void) vmssetenv(lnm,eqv,NULL);
	789	}
	790	/}}}/
	791
	792	/{{{static void vmssetuserlnm(char name, char *eqv);
	793	/* vmssetuserlnm
	794	* sets a user-mode logical in the process logical name table
	795	* used for redirection of sys$error
	796	*/
	797	void
	798	Perl_vmssetuserlnm(pTHX_ char name, char eqv)
	799	{
	800	$DESCRIPTOR(d_tab, "LNM$PROCESS");
	801	struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
	802	unsigned long int iss, attr = LNM$M_CONFINE;
	803	unsigned char acmode = PSL$C_USER;
	804	struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
	805	{0, 0, 0, 0}};
	806	d_name.dsc$a_pointer = name;
	807	d_name.dsc$w_length = strlen(name);
	808
	809	lnmlst[0].buflen = strlen(eqv);
	810	lnmlst[0].bufadr = eqv;
	811
	812	iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
	813	if (!(iss&1)) lib$signal(iss);
	814	}
	815	/}}}/
	816
	817
	818	/{{{ char my_crypt(const char textpasswd, const char usrname)*/
	819	/* my_crypt - VMS password hashing
	820	* my_crypt() provides an interface compatible with the Unix crypt()
	821	* C library function, and uses sys$hash_password() to perform VMS
	822	* password hashing. The quadword hashed password value is returned
	823	* as a NUL-terminated 8 character string. my_crypt() does not change
	824	* the case of its string arguments; in order to match the behavior
	825	* of LOGINOUT et al., alphabetic characters in both arguments must
	826	* be upcased by the caller.
	827	*/
	828	char *
	829	Perl_my_crypt(pTHX_ const char textpasswd, const char usrname)
	830	{
	831	# ifndef UAI$C_PREFERRED_ALGORITHM
	832	# define UAI$C_PREFERRED_ALGORITHM 127
	833	# endif
	834	unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
	835	unsigned short int salt = 0;
	836	unsigned long int sts;
	837	struct const_dsc {
	838	unsigned short int dsc$w_length;
	839	unsigned char dsc$b_type;
	840	unsigned char dsc$b_class;
	841	const char * dsc$a_pointer;
	842	} usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
	843	txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
	844	struct itmlst_3 uailst[3] = {
	845	{ sizeof alg, UAI$_ENCRYPT, &alg, 0},
	846	{ sizeof salt, UAI$_SALT, &salt, 0},
	847	{ 0, 0, NULL, NULL}};
	848	static char hash[9];
	849
	850	usrdsc.dsc$w_length = strlen(usrname);
	851	usrdsc.dsc$a_pointer = usrname;
	852	if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
	853	switch (sts) {
	854	case SS$_NOGRPPRV: case SS$_NOSYSPRV:
	855	set_errno(EACCES);
	856	break;
	857	case RMS$_RNF:
	858	set_errno(ESRCH); /* There isn't a Unix no-such-user error */
	859	break;
	860	default:
	861	set_errno(EVMSERR);
	862	}
	863	set_vaxc_errno(sts);
	864	if (sts != RMS$_RNF) return NULL;
	865	}
	866
	867	txtdsc.dsc$w_length = strlen(textpasswd);
	868	txtdsc.dsc$a_pointer = textpasswd;
	869	if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
	870	set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
	871	}
	872
	873	return (char *) hash;
	874
	875	} /* end of my_crypt() */
	876	/}}}/
	877
	878
	879	static char mp_do_rmsexpand(pTHX_ char , char , int, char , unsigned);
	880	static char mp_do_fileify_dirspec(pTHX_ char , char *, int);
	881	static char mp_do_tovmsspec(pTHX_ char , char *, int);
	882
	883	/{{{int do_rmdir(char name)*/
	884	int
	885	Perl_do_rmdir(pTHX_ char *name)
	886	{
	887	char dirfile[NAM$C_MAXRSS+1];
	888	int retval;
	889	Stat_t st;
	890
	891	if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
	892	if (flex_stat(dirfile,&st) \|\| !S_ISDIR(st.st_mode)) retval = -1;
	893	else retval = kill_file(dirfile);
	894	return retval;
	895
	896	} /* end of do_rmdir */
	897	/}}}/
	898
	899	/* kill_file
	900	* Delete any file to which user has control access, regardless of whether
	901	* delete access is explicitly allowed.
	902	* Limitations: User must have write access to parent directory.
	903	* Does not block signals or ASTs; if interrupted in midstream
	904	* may leave file with an altered ACL.
	905	* HANDLE WITH CARE!
	906	*/
	907	/{{{int kill_file(char name)*/
	908	int
	909	Perl_kill_file(pTHX_ char *name)
	910	{
	911	char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
	912	unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
	913	unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
	914	struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
	915	struct myacedef {
	916	unsigned char myace$b_length;
	917	unsigned char myace$b_type;
	918	unsigned short int myace$w_flags;
	919	unsigned long int myace$l_access;
	920	unsigned long int myace$l_ident;
	921	} newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
	922	ACE$M_READ \| ACE$M_WRITE \| ACE$M_DELETE \| ACE$M_CONTROL, 0},
	923	oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
	924	struct itmlst_3
	925	findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
	926	{sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
	927	addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
	928	dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
	929	lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
	930	ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
	931
	932	/* Expand the input spec using RMS, since the CRTL remove() and
	933	* system services won't do this by themselves, so we may miss
	934	* a file "hiding" behind a logical name or search list. */
	935	if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
	936	if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
	937	if (!remove(rspec)) return 0; /* Can we just get rid of it? */
	938	/* If not, can changing protections help? */
	939	if (vaxc$errno != RMS$_PRV) return -1;
	940
	941	/* No, so we get our own UIC to use as a rights identifier,
	942	* and the insert an ACE at the head of the ACL which allows us
	943	* to delete the file.
	944	*/
	945	_ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
	946	fildsc.dsc$w_length = strlen(rspec);
	947	fildsc.dsc$a_pointer = rspec;
	948	cxt = 0;
	949	newace.myace$l_ident = oldace.myace$l_ident;
	950	if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
	951	switch (aclsts) {
	952	case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
	953	set_errno(ENOENT); break;
	954	case RMS$_DIR:
	955	set_errno(ENOTDIR); break;
	956	case RMS$_DEV:
	957	set_errno(ENODEV); break;
	958	case RMS$_SYN: case SS$_INVFILFOROP:
	959	set_errno(EINVAL); break;
	960	case RMS$_PRV:
	961	set_errno(EACCES); break;
	962	default:
	963	_ckvmssts(aclsts);
	964	}
	965	set_vaxc_errno(aclsts);
	966	return -1;
	967	}
	968	/* Grab any existing ACEs with this identifier in case we fail */
	969	aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
	970	if ( fndsts & 1 \|\| fndsts == SS$_ACLEMPTY \|\| fndsts == SS$_NOENTRY
	971	\|\| fndsts == SS$_NOMOREACE ) {
	972	/* Add the new ACE . . . */
	973	if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
	974	goto yourroom;
	975	if ((rmsts = remove(name))) {
	976	/* We blew it - dir with files in it, no write priv for
	977	* parent directory, etc. Put things back the way they were. */
	978	if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
	979	goto yourroom;
	980	if (fndsts & 1) {
	981	addlst[0].bufadr = &oldace;
	982	if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
	983	goto yourroom;
	984	}
	985	}
	986	}
	987
	988	yourroom:
	989	fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
	990	/* We just deleted it, so of course it's not there. Some versions of
	991	* VMS seem to return success on the unlock operation anyhow (after all
	992	* the unlock is successful), but others don't.
	993	*/
	994	if (fndsts == RMS$_FNF \|\| fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
	995	if (aclsts & 1) aclsts = fndsts;
	996	if (!(aclsts & 1)) {
	997	set_errno(EVMSERR);
	998	set_vaxc_errno(aclsts);
	999	return -1;
	1000	}
	1001
	1002	return rmsts;
	1003
	1004	} /* end of kill_file() */
	1005	/}}}/
	1006
	1007
	1008	/{{{int my_mkdir(char ,Mode_t)*/
	1009	int
	1010	Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
	1011	{
	1012	STRLEN dirlen = strlen(dir);
	1013
	1014	/* zero length string sometimes gives ACCVIO */
	1015	if (dirlen == 0) return -1;
	1016
	1017	/* CRTL mkdir() doesn't tolerate trailing /, since that implies
	1018	* null file name/type. However, it's commonplace under Unix,
	1019	* so we'll allow it for a gain in portability.
	1020	*/
	1021	if (dir[dirlen-1] == '/') {
	1022	char *newdir = savepvn(dir,dirlen-1);
	1023	int ret = mkdir(newdir,mode);
	1024	Safefree(newdir);
	1025	return ret;
	1026	}
	1027	else return mkdir(dir,mode);
	1028	} /* end of my_mkdir */
	1029	/}}}/
	1030
	1031	/{{{int my_chdir(char )*/
	1032	int
	1033	Perl_my_chdir(pTHX_ char *dir)
	1034	{
	1035	STRLEN dirlen = strlen(dir);
	1036
	1037	/* zero length string sometimes gives ACCVIO */
	1038	if (dirlen == 0) return -1;
	1039
	1040	/* some versions of CRTL chdir() doesn't tolerate trailing /, since
	1041	* that implies
	1042	* null file name/type. However, it's commonplace under Unix,
	1043	* so we'll allow it for a gain in portability.
	1044	*/
	1045	if (dir[dirlen-1] == '/') {
	1046	char *newdir = savepvn(dir,dirlen-1);
	1047	int ret = chdir(newdir);
	1048	Safefree(newdir);
	1049	return ret;
	1050	}
	1051	else return chdir(dir);
	1052	} /* end of my_chdir */
	1053	/}}}/
	1054
	1055
	1056	/{{{FILE my_tmpfile()*/
	1057	FILE *
	1058	my_tmpfile(void)
	1059	{
	1060	FILE *fp;
	1061	char *cp;
	1062
	1063	if ((fp = tmpfile())) return fp;
	1064
	1065	New(1323,cp,L_tmpnam+24,char);
	1066	strcpy(cp,"Sys$Scratch:");
	1067	tmpnam(cp+strlen(cp));
	1068	strcat(cp,".Perltmp");
	1069	fp = fopen(cp,"w+","fop=dlt");
	1070	Safefree(cp);
	1071	return fp;
	1072	}
	1073	/}}}/
	1074
	1075
	1076	#ifndef HOMEGROWN_POSIX_SIGNALS
	1077	/*
	1078	* The C RTL's sigaction fails to check for invalid signal numbers so we
	1079	* help it out a bit. The docs are correct, but the actual routine doesn't
	1080	* do what the docs say it will.
	1081	*/
	1082	/{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction, struct sigaction);/
	1083	int
	1084	Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
	1085	struct sigaction* oact)
	1086	{
	1087	if (sig == SIGKILL \|\| sig == SIGSTOP \|\| sig == SIGCONT) {
	1088	SETERRNO(EINVAL, SS$_INVARG);
	1089	return -1;
	1090	}
	1091	return sigaction(sig, act, oact);
	1092	}
	1093	/}}}/
	1094	#endif
	1095
	1096	/* default piping mailbox size */
	1097	#define PERL_BUFSIZ 512
	1098
	1099
	1100	static void
	1101	create_mbx(pTHX_ unsigned short int chan, struct dsc$descriptor_s namdsc)
	1102	{
	1103	unsigned long int mbxbufsiz;
	1104	static unsigned long int syssize = 0;
	1105	unsigned long int dviitm = DVI$_DEVNAM;
	1106	char csize[LNM$C_NAMLENGTH+1];
	1107
	1108	if (!syssize) {
	1109	unsigned long syiitm = SYI$_MAXBUF;
	1110	/*
	1111	* Get the SYSGEN parameter MAXBUF
	1112	*
	1113	* If the logical 'PERL_MBX_SIZE' is defined
	1114	* use the value of the logical instead of PERL_BUFSIZ, but
	1115	* keep the size between 128 and MAXBUF.
	1116	*
	1117	*/
	1118	_ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
	1119	}
	1120
	1121	if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
	1122	mbxbufsiz = atoi(csize);
	1123	} else {
	1124	mbxbufsiz = PERL_BUFSIZ;
	1125	}
	1126	if (mbxbufsiz < 128) mbxbufsiz = 128;
	1127	if (mbxbufsiz > syssize) mbxbufsiz = syssize;
	1128
	1129	_ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
	1130
	1131	_ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
	1132	namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
	1133
	1134	} /* end of create_mbx() */
	1135
	1136
	1137	/{{{ my_popen and my_pclose/
	1138
	1139	typedef struct _iosb IOSB;
	1140	typedef struct _iosb* pIOSB;
	1141	typedef struct _pipe Pipe;
	1142	typedef struct _pipe* pPipe;
	1143	typedef struct pipe_details Info;
	1144	typedef struct pipe_details* pInfo;
	1145	typedef struct _srqp RQE;
	1146	typedef struct _srqp* pRQE;
	1147	typedef struct _tochildbuf CBuf;
	1148	typedef struct _tochildbuf* pCBuf;
	1149
	1150	struct _iosb {
	1151	unsigned short status;
	1152	unsigned short count;
	1153	unsigned long dvispec;
	1154	};
	1155
	1156	#pragma member_alignment save
	1157	#pragma nomember_alignment quadword
	1158	struct _srqp { /* VMS self-relative queue entry */
	1159	unsigned long qptr[2];
	1160	};
	1161	#pragma member_alignment restore
	1162	static RQE RQE_ZERO = {0,0};
	1163
	1164	struct _tochildbuf {
	1165	RQE q;
	1166	int eof;
	1167	unsigned short size;
	1168	char *buf;
	1169	};
	1170
	1171	struct _pipe {
	1172	RQE free;
	1173	RQE wait;
	1174	int fd_out;
	1175	unsigned short chan_in;
	1176	unsigned short chan_out;
	1177	char *buf;
	1178	unsigned int bufsize;
	1179	IOSB iosb;
	1180	IOSB iosb2;
	1181	int *pipe_done;
	1182	int retry;
	1183	int type;
	1184	int shut_on_empty;
	1185	int need_wake;
	1186	pPipe *home;
	1187	pInfo info;
	1188	pCBuf curr;
	1189	pCBuf curr2;
	1190	#if defined(PERL_IMPLICIT_CONTEXT)
	1191	void thx; / Either a thread or an interpreter */
	1192	/* pointer, depending on how we're built */
	1193	#endif
	1194	};
	1195
	1196
	1197	struct pipe_details
	1198	{
	1199	pInfo next;
	1200	PerlIO fp; / stdio file pointer to pipe mailbox */
	1201	int pid; /* PID of subprocess */
	1202	int mode; /* == 'r' if pipe open for reading */
	1203	int done; /* subprocess has completed */
	1204	int closing; /* my_pclose is closing this pipe */
	1205	unsigned long completion; /* termination status of subprocess */
	1206	pPipe in; /* pipe in to sub */
	1207	pPipe out; /* pipe out of sub */
	1208	pPipe err; /* pipe of sub's sys$error */
	1209	int in_done; /* true when in pipe finished */
	1210	int out_done;
	1211	int err_done;
	1212	};
	1213
	1214	struct exit_control_block
	1215	{
	1216	struct exit_control_block *flink;
	1217	unsigned long int (*exit_routine)();
	1218	unsigned long int arg_count;
	1219	unsigned long int *status_address;
	1220	unsigned long int exit_status;
	1221	};
	1222
	1223	#define RETRY_DELAY "0 ::0.20"
	1224	#define MAX_RETRY 50
	1225
	1226	static int pipe_ef = 0; /* first call to safe_popen inits these*/
	1227	static unsigned long mypid;
	1228	static unsigned long delaytime[2];
	1229
	1230	static pInfo open_pipes = NULL;
	1231	static $DESCRIPTOR(nl_desc, "NL:");
	1232
	1233
	1234	static unsigned long int
	1235	pipe_exit_routine(pTHX)
	1236	{
	1237	pInfo info;
	1238	unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
	1239	int sts, did_stuff, need_eof;
	1240
	1241	/*
	1242	first we try sending an EOF...ignore if doesn't work, make sure we
	1243	don't hang
	1244	*/
	1245	did_stuff = 0;
	1246	info = open_pipes;
	1247
	1248	while (info) {
	1249	int need_eof;
	1250	_ckvmssts(sys$setast(0));
	1251	if (info->in && !info->in->shut_on_empty) {
	1252	_ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
	1253	0, 0, 0, 0, 0, 0));
	1254	did_stuff = 1;
	1255	}
	1256	_ckvmssts(sys$setast(1));
	1257	info = info->next;
	1258	}
	1259	if (did_stuff) sleep(1); /* wait for EOF to have an effect */
	1260
	1261	did_stuff = 0;
	1262	info = open_pipes;
	1263	while (info) {
	1264	_ckvmssts(sys$setast(0));
	1265	if (!info->done) { /* Tap them gently on the shoulder . . .*/
	1266	sts = sys$forcex(&info->pid,0,&abort);
	1267	if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
	1268	did_stuff = 1;
	1269	}
	1270	_ckvmssts(sys$setast(1));
	1271	info = info->next;
	1272	}
	1273	if (did_stuff) sleep(1); /* wait for them to respond */
	1274
	1275	info = open_pipes;
	1276	while (info) {
	1277	_ckvmssts(sys$setast(0));
	1278	if (!info->done) { /* We tried to be nice . . . */
	1279	sts = sys$delprc(&info->pid,0);
	1280	if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
	1281	}
	1282	_ckvmssts(sys$setast(1));
	1283	info = info->next;
	1284	}
	1285
	1286	while(open_pipes) {
	1287	if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
	1288	else if (!(sts & 1)) retsts = sts;
	1289	}
	1290	return retsts;
	1291	}
	1292
	1293	static struct exit_control_block pipe_exitblock =
	1294	{(struct exit_control_block *) 0,
	1295	pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
	1296
	1297	static void pipe_mbxtofd_ast(pPipe p);
	1298	static void pipe_tochild1_ast(pPipe p);
	1299	static void pipe_tochild2_ast(pPipe p);
	1300
	1301	static void
	1302	popen_completion_ast(pInfo info)
	1303	{
	1304	pInfo i = open_pipes;
	1305	int iss;
	1306
	1307	while (i) {
	1308	if (i == info) break;
	1309	i = i->next;
	1310	}
	1311	if (!i) return; /* unlinked, probably freed too */
	1312
	1313	info->completion &= 0x0FFFFFFF; /* strip off "control" field */
	1314	info->done = TRUE;
	1315
	1316	/*
	1317	Writing to subprocess ...
	1318	if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
	1319
	1320	chan_out may be waiting for "done" flag, or hung waiting
	1321	for i/o completion to child...cancel the i/o. This will
	1322	put it into "snarf mode" (done but no EOF yet) that discards
	1323	input.
	1324
	1325	Output from subprocess (stdout, stderr) needs to be flushed and
	1326	shut down. We try sending an EOF, but if the mbx is full the pipe
	1327	routine should still catch the "shut_on_empty" flag, telling it to
	1328	use immediate-style reads so that "mbx empty" -> EOF.
	1329
	1330
	1331	*/
	1332	if (info->in && !info->in_done) { /* only for mode=w */
	1333	if (info->in->shut_on_empty && info->in->need_wake) {
	1334	info->in->need_wake = FALSE;
	1335	_ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
	1336	} else {
	1337	_ckvmssts_noperl(sys$cancel(info->in->chan_out));
	1338	}
	1339	}
	1340
	1341	if (info->out && !info->out_done) { /* were we also piping output? */
	1342	info->out->shut_on_empty = TRUE;
	1343	iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF\|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
	1344	if (iss == SS$_MBFULL) iss = SS$_NORMAL;
	1345	_ckvmssts_noperl(iss);
	1346	}
	1347
	1348	if (info->err && !info->err_done) { /* we were piping stderr */
	1349	info->err->shut_on_empty = TRUE;
	1350	iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF\|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
	1351	if (iss == SS$_MBFULL) iss = SS$_NORMAL;
	1352	_ckvmssts_noperl(iss);
	1353	}
	1354	_ckvmssts_noperl(sys$setef(pipe_ef));
	1355
	1356	}
	1357
	1358	static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img);
	1359	static void vms_execfree(pTHX);
	1360
	1361	/*
	1362	we actually differ from vmstrnenv since we use this to
	1363	get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR really
	1364	are pointing to the same thing
	1365	*/
	1366
	1367	static unsigned short
	1368	popen_translate(pTHX_ char logical, char result)
	1369	{
	1370	int iss;
	1371	$DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
	1372	$DESCRIPTOR(d_log,"");
	1373	struct _il3 {
	1374	unsigned short length;
	1375	unsigned short code;
	1376	char * buffer_addr;
	1377	unsigned short *retlenaddr;
	1378	} itmlst[2];
	1379	unsigned short l, ifi;
	1380
	1381	d_log.dsc$a_pointer = logical;
	1382	d_log.dsc$w_length = strlen(logical);
	1383
	1384	itmlst[0].code = LNM$_STRING;
	1385	itmlst[0].length = 255;
	1386	itmlst[0].buffer_addr = result;
	1387	itmlst[0].retlenaddr = &l;
	1388
	1389	itmlst[1].code = 0;
	1390	itmlst[1].length = 0;
	1391	itmlst[1].buffer_addr = 0;
	1392	itmlst[1].retlenaddr = 0;
	1393
	1394	iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
	1395	if (iss == SS$_NOLOGNAM) {
	1396	iss = SS$_NORMAL;
	1397	l = 0;
	1398	}
	1399	if (!(iss&1)) lib$signal(iss);
	1400	result[l] = '\0';
	1401	/*
	1402	logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
	1403	strip it off and return the ifi, if any
	1404	*/
	1405	ifi = 0;
	1406	if (result[0] == 0x1b && result[1] == 0x00) {
	1407	memcpy(&ifi,result+2,2);
	1408	strcpy(result,result+4);
	1409	}
	1410	return ifi; /* this is the RMS internal file id */
	1411	}
	1412
	1413	#define MAX_DCL_SYMBOL 255
	1414	static void pipe_infromchild_ast(pPipe p);
	1415
	1416	/*
	1417	I'm using LIB$(GET\|FREE)_VM here so that we can allocate and deallocate
	1418	inside an AST routine without worrying about reentrancy and which Perl
	1419	memory allocator is being used.
	1420
	1421	We read data and queue up the buffers, then spit them out one at a
	1422	time to the output mailbox when the output mailbox is ready for one.
	1423
	1424	*/
	1425	#define INITIAL_TOCHILDQUEUE 2
	1426
	1427	static pPipe
	1428	pipe_tochild_setup(pTHX_ char rmbx, char wmbx)
	1429	{
	1430	pPipe p;
	1431	pCBuf b;
	1432	char mbx1[64], mbx2[64];
	1433	struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
	1434	DSC$K_CLASS_S, mbx1},
	1435	d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
	1436	DSC$K_CLASS_S, mbx2};
	1437	unsigned int dviitm = DVI$_DEVBUFSIZ;
	1438	int j, n;
	1439
	1440	New(1368, p, 1, Pipe);
	1441
	1442	create_mbx(aTHX_ &p->chan_in , &d_mbx1);
	1443	create_mbx(aTHX_ &p->chan_out, &d_mbx2);
	1444	_ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
	1445
	1446	p->buf = 0;
	1447	p->shut_on_empty = FALSE;
	1448	p->need_wake = FALSE;
	1449	p->type = 0;
	1450	p->retry = 0;
	1451	p->iosb.status = SS$_NORMAL;
	1452	p->iosb2.status = SS$_NORMAL;
	1453	p->free = RQE_ZERO;
	1454	p->wait = RQE_ZERO;
	1455	p->curr = 0;
	1456	p->curr2 = 0;
	1457	p->info = 0;
	1458	#ifdef PERL_IMPLICIT_CONTEXT
	1459	p->thx = aTHX;
	1460	#endif
	1461
	1462	n = sizeof(CBuf) + p->bufsize;
	1463
	1464	for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
	1465	_ckvmssts(lib$get_vm(&n, &b));
	1466	b->buf = (char *) b + sizeof(CBuf);
	1467	_ckvmssts(lib$insqhi(b, &p->free));
	1468	}
	1469
	1470	pipe_tochild2_ast(p);
	1471	pipe_tochild1_ast(p);
	1472	strcpy(wmbx, mbx1);
	1473	strcpy(rmbx, mbx2);
	1474	return p;
	1475	}
	1476
	1477	/* reads the MBX Perl is writing, and queues */
	1478
	1479	static void
	1480	pipe_tochild1_ast(pPipe p)
	1481	{
	1482	pCBuf b = p->curr;
	1483	int iss = p->iosb.status;
	1484	int eof = (iss == SS$_ENDOFFILE);
	1485	#ifdef PERL_IMPLICIT_CONTEXT
	1486	pTHX = p->thx;
	1487	#endif
	1488
	1489	if (p->retry) {
	1490	if (eof) {
	1491	p->shut_on_empty = TRUE;
	1492	b->eof = TRUE;
	1493	_ckvmssts(sys$dassgn(p->chan_in));
	1494	} else {
	1495	_ckvmssts(iss);
	1496	}
	1497
	1498	b->eof = eof;
	1499	b->size = p->iosb.count;
	1500	_ckvmssts(lib$insqhi(b, &p->wait));
	1501	if (p->need_wake) {
	1502	p->need_wake = FALSE;
	1503	_ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
	1504	}
	1505	} else {
	1506	p->retry = 1; /* initial call */
	1507	}
	1508
	1509	if (eof) { /* flush the free queue, return when done */
	1510	int n = sizeof(CBuf) + p->bufsize;
	1511	while (1) {
	1512	iss = lib$remqti(&p->free, &b);
	1513	if (iss == LIB$_QUEWASEMP) return;
	1514	_ckvmssts(iss);
	1515	_ckvmssts(lib$free_vm(&n, &b));
	1516	}
	1517	}
	1518
	1519	iss = lib$remqti(&p->free, &b);
	1520	if (iss == LIB$_QUEWASEMP) {
	1521	int n = sizeof(CBuf) + p->bufsize;
	1522	_ckvmssts(lib$get_vm(&n, &b));
	1523	b->buf = (char *) b + sizeof(CBuf);
	1524	} else {
	1525	_ckvmssts(iss);
	1526	}
	1527
	1528	p->curr = b;
	1529	iss = sys$qio(0,p->chan_in,
	1530	IO$_READVBLK\|(p->shut_on_empty ? IO$M_NOWAIT : 0),
	1531	&p->iosb,
	1532	pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
	1533	if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
	1534	_ckvmssts(iss);
	1535	}
	1536
	1537
	1538	/* writes queued buffers to output, waits for each to complete before
	1539	doing the next */
	1540
	1541	static void
	1542	pipe_tochild2_ast(pPipe p)
	1543	{
	1544	pCBuf b = p->curr2;
	1545	int iss = p->iosb2.status;
	1546	int n = sizeof(CBuf) + p->bufsize;
	1547	int done = (p->info && p->info->done) \|\|
	1548	iss == SS$_CANCEL \|\| iss == SS$_ABORT;
	1549	#if defined(PERL_IMPLICIT_CONTEXT)
	1550	pTHX = p->thx;
	1551	#endif
	1552
	1553	do {
	1554	if (p->type) { /* type=1 has old buffer, dispose */
	1555	if (p->shut_on_empty) {
	1556	_ckvmssts(lib$free_vm(&n, &b));
	1557	} else {
	1558	_ckvmssts(lib$insqhi(b, &p->free));
	1559	}
	1560	p->type = 0;
	1561	}
	1562
	1563	iss = lib$remqti(&p->wait, &b);
	1564	if (iss == LIB$_QUEWASEMP) {
	1565	if (p->shut_on_empty) {
	1566	if (done) {
	1567	_ckvmssts(sys$dassgn(p->chan_out));
	1568	*p->pipe_done = TRUE;
	1569	_ckvmssts(sys$setef(pipe_ef));
	1570	} else {
	1571	_ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
	1572	&p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
	1573	}
	1574	return;
	1575	}
	1576	p->need_wake = TRUE;
	1577	return;
	1578	}
	1579	_ckvmssts(iss);
	1580	p->type = 1;
	1581	} while (done);
	1582
	1583
	1584	p->curr2 = b;
	1585	if (b->eof) {
	1586	_ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
	1587	&p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
	1588	} else {
	1589	_ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
	1590	&p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
	1591	}
	1592
	1593	return;
	1594
	1595	}
	1596
	1597
	1598	static pPipe
	1599	pipe_infromchild_setup(pTHX_ char rmbx, char wmbx)
	1600	{
	1601	pPipe p;
	1602	char mbx1[64], mbx2[64];
	1603	struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
	1604	DSC$K_CLASS_S, mbx1},
	1605	d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
	1606	DSC$K_CLASS_S, mbx2};
	1607	unsigned int dviitm = DVI$_DEVBUFSIZ;
	1608
	1609	New(1367, p, 1, Pipe);
	1610	create_mbx(aTHX_ &p->chan_in , &d_mbx1);
	1611	create_mbx(aTHX_ &p->chan_out, &d_mbx2);
	1612
	1613	_ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
	1614	New(1367, p->buf, p->bufsize, char);
	1615	p->shut_on_empty = FALSE;
	1616	p->info = 0;
	1617	p->type = 0;
	1618	p->iosb.status = SS$_NORMAL;
	1619	#if defined(PERL_IMPLICIT_CONTEXT)
	1620	p->thx = aTHX;
	1621	#endif
	1622	pipe_infromchild_ast(p);
	1623
	1624	strcpy(wmbx, mbx1);
	1625	strcpy(rmbx, mbx2);
	1626	return p;
	1627	}
	1628
	1629	static void
	1630	pipe_infromchild_ast(pPipe p)
	1631	{
	1632	int iss = p->iosb.status;
	1633	int eof = (iss == SS$_ENDOFFILE);
	1634	int myeof = (eof && (p->iosb.dvispec == mypid \|\| p->iosb.dvispec == 0));
	1635	int kideof = (eof && (p->iosb.dvispec == p->info->pid));
	1636	#if defined(PERL_IMPLICIT_CONTEXT)
	1637	pTHX = p->thx;
	1638	#endif
	1639
	1640	if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
	1641	_ckvmssts(sys$dassgn(p->chan_out));
	1642	p->chan_out = 0;
	1643	}
	1644
	1645	/* read completed:
	1646	input shutdown if EOF from self (done or shut_on_empty)
	1647	output shutdown if closing flag set (my_pclose)
	1648	send data/eof from child or eof from self
	1649	otherwise, re-read (snarf of data from child)
	1650	*/
	1651
	1652	if (p->type == 1) {
	1653	p->type = 0;
	1654	if (myeof && p->chan_in) { /* input shutdown */
	1655	_ckvmssts(sys$dassgn(p->chan_in));
	1656	p->chan_in = 0;
	1657	}
	1658
	1659	if (p->chan_out) {
	1660	if (myeof \|\| kideof) { /* pass EOF to parent */
	1661	_ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
	1662	pipe_infromchild_ast, p,
	1663	0, 0, 0, 0, 0, 0));
	1664	return;
	1665	} else if (eof) { /* eat EOF --- fall through to read*/
	1666
	1667	} else { /* transmit data */
	1668	_ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
	1669	pipe_infromchild_ast,p,
	1670	p->buf, p->iosb.count, 0, 0, 0, 0));
	1671	return;
	1672	}
	1673	}
	1674	}
	1675
	1676	/* everything shut? flag as done */
	1677
	1678	if (!p->chan_in && !p->chan_out) {
	1679	*p->pipe_done = TRUE;
	1680	_ckvmssts(sys$setef(pipe_ef));
	1681	return;
	1682	}
	1683
	1684	/* write completed (or read, if snarfing from child)
	1685	if still have input active,
	1686	queue read...immediate mode if shut_on_empty so we get EOF if empty
	1687	otherwise,
	1688	check if Perl reading, generate EOFs as needed
	1689	*/
	1690
	1691	if (p->type == 0) {
	1692	p->type = 1;
	1693	if (p->chan_in) {
	1694	iss = sys$qio(0,p->chan_in,IO$_READVBLK\|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
	1695	pipe_infromchild_ast,p,
	1696	p->buf, p->bufsize, 0, 0, 0, 0);
	1697	if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
	1698	_ckvmssts(iss);
	1699	} else { /* send EOFs for extra reads */
	1700	p->iosb.status = SS$_ENDOFFILE;
	1701	p->iosb.dvispec = 0;
	1702	_ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE\|IO$M_READATTN,
	1703	0, 0, 0,
	1704	pipe_infromchild_ast, p, 0, 0, 0, 0));
	1705	}
	1706	}
	1707	}
	1708
	1709	static pPipe
	1710	pipe_mbxtofd_setup(pTHX_ int fd, char *out)
	1711	{
	1712	pPipe p;
	1713	char mbx[64];
	1714	unsigned long dviitm = DVI$_DEVBUFSIZ;
	1715	struct stat s;
	1716	struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
	1717	DSC$K_CLASS_S, mbx};
	1718
	1719	/* things like terminals and mbx's don't need this filter */
	1720	if (fd && fstat(fd,&s) == 0) {
	1721	unsigned long dviitm = DVI$_DEVCHAR, devchar;
	1722	struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
	1723	DSC$K_CLASS_S, s.st_dev};
	1724
	1725	_ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
	1726	if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
	1727	strcpy(out, s.st_dev);
	1728	return 0;
	1729	}
	1730	}
	1731
	1732	New(1366, p, 1, Pipe);
	1733	p->fd_out = dup(fd);
	1734	create_mbx(aTHX_ &p->chan_in, &d_mbx);
	1735	_ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
	1736	New(1366, p->buf, p->bufsize+1, char);
	1737	p->shut_on_empty = FALSE;
	1738	p->retry = 0;
	1739	p->info = 0;
	1740	strcpy(out, mbx);
	1741
	1742	_ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
	1743	pipe_mbxtofd_ast, p,
	1744	p->buf, p->bufsize, 0, 0, 0, 0));
	1745
	1746	return p;
	1747	}
	1748
	1749	static void
	1750	pipe_mbxtofd_ast(pPipe p)
	1751	{
	1752	int iss = p->iosb.status;
	1753	int done = p->info->done;
	1754	int iss2;
	1755	int eof = (iss == SS$_ENDOFFILE);
	1756	int myeof = eof && ((p->iosb.dvispec == mypid)\|\|(p->iosb.dvispec == 0));
	1757	int err = !(iss&1) && !eof;
	1758	#if defined(PERL_IMPLICIT_CONTEXT)
	1759	pTHX = p->thx;
	1760	#endif
	1761
	1762	if (done && myeof) { /* end piping */
	1763	close(p->fd_out);
	1764	sys$dassgn(p->chan_in);
	1765	*p->pipe_done = TRUE;
	1766	_ckvmssts(sys$setef(pipe_ef));
	1767	return;
	1768	}
	1769
	1770	if (!err && !eof) { /* good data to send to file */
	1771	p->buf[p->iosb.count] = '\n';
	1772	iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
	1773	if (iss2 < 0) {
	1774	p->retry++;
	1775	if (p->retry < MAX_RETRY) {
	1776	_ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
	1777	return;
	1778	}
	1779	}
	1780	p->retry = 0;
	1781	} else if (err) {
	1782	_ckvmssts(iss);
	1783	}
	1784
	1785
	1786	iss = sys$qio(0, p->chan_in, IO$_READVBLK\|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
	1787	pipe_mbxtofd_ast, p,
	1788	p->buf, p->bufsize, 0, 0, 0, 0);
	1789	if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
	1790	_ckvmssts(iss);
	1791	}
	1792
	1793
	1794	typedef struct _pipeloc PLOC;
	1795	typedef struct _pipeloc* pPLOC;
	1796
	1797	struct _pipeloc {
	1798	pPLOC next;
	1799	char dir[NAM$C_MAXRSS+1];
	1800	};
	1801	static pPLOC head_PLOC = 0;
	1802
	1803	void
	1804	free_pipelocs(pTHX_ void *head)
	1805	{
	1806	pPLOC p, pnext;
	1807
	1808	p = (pPLOC) head;
	1809	while (p) {
	1810	pnext = p->next;
	1811	Safefree(p);
	1812	p = pnext;
	1813	}
	1814	}
	1815
	1816	static void
	1817	store_pipelocs(pTHX)
	1818	{
	1819	int i;
	1820	pPLOC p;
	1821	AV *av = GvAVn(PL_incgv);
	1822	SV *dirsv;
	1823	GV *gv;
	1824	char dir, x;
	1825	char *unixdir;
	1826	char temp[NAM$C_MAXRSS+1];
	1827	STRLEN n_a;
	1828
	1829	/* the . directory from @INC comes last */
	1830
	1831	New(1370,p,1,PLOC);
	1832	p->next = head_PLOC;
	1833	head_PLOC = p;
	1834	strcpy(p->dir,"./");
	1835
	1836	/* get the directory from $^X */
	1837
	1838	if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
	1839	strcpy(temp, PL_origargv[0]);
	1840	x = strrchr(temp,']');
	1841	if (x) x[1] = '\0';
	1842
	1843	if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
	1844	New(1370,p,1,PLOC);
	1845	p->next = head_PLOC;
	1846	head_PLOC = p;
	1847	strncpy(p->dir,unixdir,sizeof(p->dir)-1);
	1848	p->dir[NAM$C_MAXRSS] = '\0';
	1849	}
	1850	}
	1851
	1852	/* reverse order of @INC entries, skip "." since entered above */
	1853
	1854	for (i = 0; i <= AvFILL(av); i++) {
	1855	dirsv = *av_fetch(av,i,TRUE);
	1856
	1857	if (SvROK(dirsv)) continue;
	1858	dir = SvPVx(dirsv,n_a);
	1859	if (strcmp(dir,".") == 0) continue;
	1860	if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
	1861	continue;
	1862
	1863	New(1370,p,1,PLOC);
	1864	p->next = head_PLOC;
	1865	head_PLOC = p;
	1866	strncpy(p->dir,unixdir,sizeof(p->dir)-1);
	1867	p->dir[NAM$C_MAXRSS] = '\0';
	1868	}
	1869
	1870	/* most likely spot (ARCHLIB) put first in the list */
	1871
	1872	#ifdef ARCHLIB_EXP
	1873	if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
	1874	New(1370,p,1,PLOC);
	1875	p->next = head_PLOC;
	1876	head_PLOC = p;
	1877	strncpy(p->dir,unixdir,sizeof(p->dir)-1);
	1878	p->dir[NAM$C_MAXRSS] = '\0';
	1879	}
	1880	#endif
	1881	Perl_call_atexit(aTHX_ &free_pipelocs, head_PLOC);
	1882	}
	1883
	1884
	1885	static char *
	1886	find_vmspipe(pTHX)
	1887	{
	1888	static int vmspipe_file_status = 0;
	1889	static char vmspipe_file[NAM$C_MAXRSS+1];
	1890
	1891	/* already found? Check and use ... need read+execute permission */
	1892
	1893	if (vmspipe_file_status == 1) {
	1894	if (cando_by_name(S_IRUSR, 0, vmspipe_file)
	1895	&& cando_by_name(S_IXUSR, 0, vmspipe_file)) {
	1896	return vmspipe_file;
	1897	}
	1898	vmspipe_file_status = 0;
	1899	}
	1900
	1901	/* scan through stored @INC, $^X */
	1902
	1903	if (vmspipe_file_status == 0) {
	1904	char file[NAM$C_MAXRSS+1];
	1905	pPLOC p = head_PLOC;
	1906
	1907	while (p) {
	1908	strcpy(file, p->dir);
	1909	strncat(file, "vmspipe.com",NAM$C_MAXRSS);
	1910	file[NAM$C_MAXRSS] = '\0';
	1911	p = p->next;
	1912
	1913	if (!do_tovmsspec(file,vmspipe_file,0)) continue;
	1914
	1915	if (cando_by_name(S_IRUSR, 0, vmspipe_file)
	1916	&& cando_by_name(S_IXUSR, 0, vmspipe_file)) {
	1917	vmspipe_file_status = 1;
	1918	return vmspipe_file;
	1919	}
	1920	}
	1921	vmspipe_file_status = -1; /* failed, use tempfiles */
	1922	}
	1923
	1924	return 0;
	1925	}
	1926
	1927	static FILE *
	1928	vmspipe_tempfile(pTHX)
	1929	{
	1930	char file[NAM$C_MAXRSS+1];
	1931	FILE *fp;
	1932	static int index = 0;
	1933	stat_t s0, s1;
	1934
	1935	/* create a tempfile */
	1936
	1937	/* we can't go from W, shr=get to R, shr=get without
	1938	an intermediate vulnerable state, so don't bother trying...
	1939
	1940	and lib$spawn doesn't shr=put, so have to close the write
	1941
	1942	So... match up the creation date/time and the FID to
	1943	make sure we're dealing with the same file
	1944
	1945	*/
	1946
	1947	index++;
	1948	sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
	1949	fp = fopen(file,"w");
	1950	if (!fp) {
	1951	sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
	1952	fp = fopen(file,"w");
	1953	if (!fp) {
	1954	sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
	1955	fp = fopen(file,"w");
	1956	}
	1957	}
	1958	if (!fp) return 0; /* we're hosed */
	1959
	1960	fprintf(fp,"$! 'f$verify(0)\n");
	1961	fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
	1962	fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
	1963	fprintf(fp,"$ perl_define = \"define/nolog\"\n");
	1964	fprintf(fp,"$ perl_on = \"set noon\"\n");
	1965	fprintf(fp,"$ perl_exit = \"exit\"\n");
	1966	fprintf(fp,"$ perl_del = \"delete\"\n");
	1967	fprintf(fp,"$ pif = \"if\"\n");
	1968	fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
	1969	fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
	1970	fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
	1971	fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
	1972	fprintf(fp,"$ cmd = perl_popen_cmd\n");
	1973	fprintf(fp,"$! --- get rid of global symbols\n");
	1974	fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
	1975	fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
	1976	fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
	1977	fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
	1978	fprintf(fp,"$ perl_on\n");
	1979	fprintf(fp,"$ 'cmd\n");
	1980	fprintf(fp,"$ perl_status = $STATUS\n");
	1981	fprintf(fp,"$ perl_del 'perl_cfile'\n");
	1982	fprintf(fp,"$ perl_exit 'perl_status'\n");
	1983	fsync(fileno(fp));
	1984
	1985	fgetname(fp, file, 1);
	1986	fstat(fileno(fp), &s0);
	1987	fclose(fp);
	1988
	1989	fp = fopen(file,"r","shr=get");
	1990	if (!fp) return 0;
	1991	fstat(fileno(fp), &s1);
	1992
	1993	if (s0.st_ino[0] != s1.st_ino[0] \|\|
	1994	s0.st_ino[1] != s1.st_ino[1] \|\|
	1995	s0.st_ino[2] != s1.st_ino[2] \|\|
	1996	s0.st_ctime != s1.st_ctime ) {
	1997	fclose(fp);
	1998	return 0;
	1999	}
	2000
	2001	return fp;
	2002	}
	2003
	2004
	2005
	2006	static PerlIO *
	2007	safe_popen(pTHX_ char cmd, char mode)
	2008	{
	2009	static int handler_set_up = FALSE;
	2010	unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
	2011	unsigned int table = LIB$K_CLI_GLOBAL_SYM;
	2012	char p, symbol[MAX_DCL_SYMBOL+1], vmspipe;
	2013	char in[512], out[512], err[512], mbx[512];
	2014	FILE *tpipe = 0;
	2015	char tfilebuf[NAM$C_MAXRSS+1];
	2016	pInfo info;
	2017	struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
	2018	DSC$K_CLASS_S, symbol};
	2019	struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
	2020	DSC$K_CLASS_S, 0};
	2021
	2022	$DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
	2023	$DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
	2024	$DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
	2025	$DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
	2026
	2027	/* once-per-program initialization...
	2028	note that the SETAST calls and the dual test of pipe_ef
	2029	makes sure that only the FIRST thread through here does
	2030	the initialization...all other threads wait until it's
	2031	done.
	2032
	2033	Yeah, uglier than a pthread call, it's got all the stuff inline
	2034	rather than in a separate routine.
	2035	*/
	2036
	2037	if (!pipe_ef) {
	2038	_ckvmssts(sys$setast(0));
	2039	if (!pipe_ef) {
	2040	unsigned long int pidcode = JPI$_PID;
	2041	$DESCRIPTOR(d_delay, RETRY_DELAY);
	2042	_ckvmssts(lib$get_ef(&pipe_ef));
	2043	_ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
	2044	_ckvmssts(sys$bintim(&d_delay, delaytime));
	2045	}
	2046	if (!handler_set_up) {
	2047	_ckvmssts(sys$dclexh(&pipe_exitblock));
	2048	handler_set_up = TRUE;
	2049	}
	2050	_ckvmssts(sys$setast(1));
	2051	}
	2052
	2053	/* see if we can find a VMSPIPE.COM */
	2054
	2055	tfilebuf[0] = '@';
	2056	vmspipe = find_vmspipe(aTHX);
	2057	if (vmspipe) {
	2058	strcpy(tfilebuf+1,vmspipe);
	2059	} else { /* uh, oh...we're in tempfile hell */
	2060	tpipe = vmspipe_tempfile(aTHX);
	2061	if (!tpipe) { /* a fish popular in Boston */
	2062	if (ckWARN(WARN_PIPE)) {
	2063	Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
	2064	}
	2065	return Nullfp;
	2066	}
	2067	fgetname(tpipe,tfilebuf+1,1);
	2068	}
	2069	vmspipedsc.dsc$a_pointer = tfilebuf;
	2070	vmspipedsc.dsc$w_length = strlen(tfilebuf);
	2071
	2072	sts = setup_cmddsc(aTHX_ cmd,0);
	2073	if (!(sts & 1)) {
	2074	switch (sts) {
	2075	case RMS$_FNF: case RMS$_DNF:
	2076	set_errno(ENOENT); break;
	2077	case RMS$_DIR:
	2078	set_errno(ENOTDIR); break;
	2079	case RMS$_DEV:
	2080	set_errno(ENODEV); break;
	2081	case RMS$_PRV:
	2082	set_errno(EACCES); break;
	2083	case RMS$_SYN:
	2084	set_errno(EINVAL); break;
	2085	case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
	2086	set_errno(E2BIG); break;
	2087	case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
	2088	_ckvmssts(sts); /* fall through */
	2089	default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
	2090	set_errno(EVMSERR);
	2091	}
	2092	set_vaxc_errno(sts);
	2093	if (ckWARN(WARN_PIPE)) {
	2094	Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
	2095	}
	2096	return Nullfp;
	2097	}
	2098	New(1301,info,1,Info);
	2099
	2100	info->mode = *mode;
	2101	info->done = FALSE;
	2102	info->completion = 0;
	2103	info->closing = FALSE;
	2104	info->in = 0;
	2105	info->out = 0;
	2106	info->err = 0;
	2107	info->in_done = TRUE;
	2108	info->out_done = TRUE;
	2109	info->err_done = TRUE;
	2110	in[0] = out[0] = err[0] = '\0';
	2111
	2112	if (mode == 'r') { / piping from subroutine */
	2113
	2114	info->out = pipe_infromchild_setup(aTHX_ mbx,out);
	2115	if (info->out) {
	2116	info->out->pipe_done = &info->out_done;
	2117	info->out_done = FALSE;
	2118	info->out->info = info;
	2119	}
	2120	info->fp = PerlIO_open(mbx, mode);
	2121	if (!info->fp && info->out) {
	2122	sys$cancel(info->out->chan_out);
	2123
	2124	while (!info->out_done) {
	2125	int done;
	2126	_ckvmssts(sys$setast(0));
	2127	done = info->out_done;
	2128	if (!done) _ckvmssts(sys$clref(pipe_ef));
	2129	_ckvmssts(sys$setast(1));
	2130	if (!done) _ckvmssts(sys$waitfr(pipe_ef));
	2131	}
	2132
	2133	if (info->out->buf) Safefree(info->out->buf);
	2134	Safefree(info->out);
	2135	Safefree(info);
	2136	return Nullfp;
	2137	}
	2138
	2139	info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
	2140	if (info->err) {
	2141	info->err->pipe_done = &info->err_done;
	2142	info->err_done = FALSE;
	2143	info->err->info = info;
	2144	}
	2145
	2146	} else { /* piping to subroutine , mode=w*/
	2147
	2148	info->in = pipe_tochild_setup(aTHX_ in,mbx);
	2149	info->fp = PerlIO_open(mbx, mode);
	2150	if (info->in) {
	2151	info->in->pipe_done = &info->in_done;
	2152	info->in_done = FALSE;
	2153	info->in->info = info;
	2154	}
	2155
	2156	/* error cleanup */
	2157	if (!info->fp && info->in) {
	2158	info->done = TRUE;
	2159	_ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
	2160	0, 0, 0, 0, 0, 0, 0, 0));
	2161
	2162	while (!info->in_done) {
	2163	int done;
	2164	_ckvmssts(sys$setast(0));
	2165	done = info->in_done;
	2166	if (!done) _ckvmssts(sys$clref(pipe_ef));
	2167	_ckvmssts(sys$setast(1));
	2168	if (!done) _ckvmssts(sys$waitfr(pipe_ef));
	2169	}
	2170
	2171	if (info->in->buf) Safefree(info->in->buf);
	2172	Safefree(info->in);
	2173	Safefree(info);
	2174	return Nullfp;
	2175	}
	2176
	2177
	2178	info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
	2179	if (info->out) {
	2180	info->out->pipe_done = &info->out_done;
	2181	info->out_done = FALSE;
	2182	info->out->info = info;
	2183	}
	2184
	2185	info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
	2186	if (info->err) {
	2187	info->err->pipe_done = &info->err_done;
	2188	info->err_done = FALSE;
	2189	info->err->info = info;
	2190	}
	2191	}
	2192
	2193	symbol[MAX_DCL_SYMBOL] = '\0';
	2194
	2195	strncpy(symbol, in, MAX_DCL_SYMBOL);
	2196	d_symbol.dsc$w_length = strlen(symbol);
	2197	_ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
	2198
	2199	strncpy(symbol, err, MAX_DCL_SYMBOL);
	2200	d_symbol.dsc$w_length = strlen(symbol);
	2201	_ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
	2202
	2203	strncpy(symbol, out, MAX_DCL_SYMBOL);
	2204	d_symbol.dsc$w_length = strlen(symbol);
	2205	_ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
	2206
	2207	p = VMScmd.dsc$a_pointer;
	2208	while (p && p != '\n') p++;
	2209	p = '\0'; / truncate on \n */
	2210	p = VMScmd.dsc$a_pointer;
	2211	while (p == ' ' \|\| p == '\t') p++; /* remove leading whitespace */
	2212	if (p == '$') p++; / remove leading $ */
	2213	while (p == ' ' \|\| p == '\t') p++;
	2214	strncpy(symbol, p, MAX_DCL_SYMBOL);
	2215	d_symbol.dsc$w_length = strlen(symbol);
	2216	_ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
	2217
	2218	_ckvmssts(sys$setast(0));
	2219	info->next=open_pipes; /* prepend to list */
	2220	open_pipes=info;
	2221	_ckvmssts(sys$setast(1));
	2222	_ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
	2223	0, &info->pid, &info->completion,
	2224	0, popen_completion_ast,info,0,0,0));
	2225
	2226	/* if we were using a tempfile, close it now */
	2227
	2228	if (tpipe) fclose(tpipe);
	2229
	2230	/* once the subprocess is spawned, its copied the symbols and
	2231	we can get rid of ours */
	2232
	2233	_ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
	2234	_ckvmssts(lib$delete_symbol(&d_sym_in, &table));
	2235	_ckvmssts(lib$delete_symbol(&d_sym_err, &table));
	2236	_ckvmssts(lib$delete_symbol(&d_sym_out, &table));
	2237	vms_execfree(aTHX);
	2238
	2239	PL_forkprocess = info->pid;
	2240	return info->fp;
	2241	} /* end of safe_popen */
	2242
	2243
	2244	/{{{ PerlIO my_popen(char cmd, char mode)*/
	2245	PerlIO *
	2246	Perl_my_popen(pTHX_ char cmd, char mode)
	2247	{
	2248	TAINT_ENV();
	2249	TAINT_PROPER("popen");
	2250	PERL_FLUSHALL_FOR_CHILD;
	2251	return safe_popen(aTHX_ cmd,mode);
	2252	}
	2253
	2254	/}}}/
	2255
	2256	/{{{ I32 my_pclose(PerlIO fp)*/
	2257	I32 Perl_my_pclose(pTHX_ PerlIO *fp)
	2258	{
	2259	pInfo info, last = NULL;
	2260	unsigned long int retsts;
	2261	int done, iss;
	2262
	2263	for (info = open_pipes; info != NULL; last = info, info = info->next)
	2264	if (info->fp == fp) break;
	2265
	2266	if (info == NULL) { /* no such pipe open */
	2267	set_errno(ECHILD); /* quoth POSIX */
	2268	set_vaxc_errno(SS$_NONEXPR);
	2269	return -1;
	2270	}
	2271
	2272	/* If we were writing to a subprocess, insure that someone reading from
	2273	* the mailbox gets an EOF. It looks like a simple fclose() doesn't
	2274	* produce an EOF record in the mailbox.
	2275	*
	2276	* well, at least sometimes it does, so we have to watch out for
	2277	* the first EOF closing the pipe (and DASSGN'ing the channel)...
	2278	*/
	2279
	2280	PerlIO_flush(info->fp); /* first, flush data */
	2281
	2282	_ckvmssts(sys$setast(0));
	2283	info->closing = TRUE;
	2284	done = info->done && info->in_done && info->out_done && info->err_done;
	2285	/* hanging on write to Perl's input? cancel it */
	2286	if (info->mode == 'r' && info->out && !info->out_done) {
	2287	if (info->out->chan_out) {
	2288	_ckvmssts(sys$cancel(info->out->chan_out));
	2289	if (!info->out->chan_in) { /* EOF generation, need AST */
	2290	_ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
	2291	}
	2292	}
	2293	}
	2294	if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
	2295	_ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
	2296	0, 0, 0, 0, 0, 0));
	2297	_ckvmssts(sys$setast(1));
	2298	PerlIO_close(info->fp);
	2299
	2300	/*
	2301	we have to wait until subprocess completes, but ALSO wait until all
	2302	the i/o completes...otherwise we'll be freeing the "info" structure
	2303	that the i/o ASTs could still be using...
	2304	*/
	2305
	2306	while (!done) {
	2307	_ckvmssts(sys$setast(0));
	2308	done = info->done && info->in_done && info->out_done && info->err_done;
	2309	if (!done) _ckvmssts(sys$clref(pipe_ef));
	2310	_ckvmssts(sys$setast(1));
	2311	if (!done) _ckvmssts(sys$waitfr(pipe_ef));
	2312	}
	2313	retsts = info->completion;
	2314
	2315	/* remove from list of open pipes */
	2316	_ckvmssts(sys$setast(0));
	2317	if (last) last->next = info->next;
	2318	else open_pipes = info->next;
	2319	_ckvmssts(sys$setast(1));
	2320
	2321	/* free buffers and structures */
	2322
	2323	if (info->in) {
	2324	if (info->in->buf) Safefree(info->in->buf);
	2325	Safefree(info->in);
	2326	}
	2327	if (info->out) {
	2328	if (info->out->buf) Safefree(info->out->buf);
	2329	Safefree(info->out);
	2330	}
	2331	if (info->err) {
	2332	if (info->err->buf) Safefree(info->err->buf);
	2333	Safefree(info->err);
	2334	}
	2335	Safefree(info);
	2336
	2337	return retsts;
	2338
	2339	} /* end of my_pclose() */
	2340
	2341	#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
	2342	/* Roll our own prototype because we want this regardless of whether
	2343	* _VMS_WAIT is defined.
	2344	*/
	2345	__pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
	2346	#endif
	2347	/* sort-of waitpid; special handling of pipe clean-up for subprocesses
	2348	created with popen(); otherwise partially emulate waitpid() unless
	2349	we have a suitable one from the CRTL that came with VMS 7.2 and later.
	2350	Also check processes not considered by the CRTL waitpid().
	2351	*/
	2352	/{{{Pid_t my_waitpid(Pid_t pid, int statusp, int flags)*/
	2353	Pid_t
	2354	Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
	2355	{
	2356	pInfo info;
	2357	int done;
	2358	int sts;
	2359
	2360	if (statusp) *statusp = 0;
	2361
	2362	for (info = open_pipes; info != NULL; info = info->next)
	2363	if (info->pid == pid) break;
	2364
	2365	if (info != NULL) { /* we know about this child */
	2366	while (!info->done) {
	2367	_ckvmssts(sys$setast(0));
	2368	done = info->done;
	2369	if (!done) _ckvmssts(sys$clref(pipe_ef));
	2370	_ckvmssts(sys$setast(1));
	2371	if (!done) _ckvmssts(sys$waitfr(pipe_ef));
	2372	}
	2373
	2374	if (statusp) *statusp = info->completion;
	2375	return pid;
	2376
	2377	}
	2378	else { /* this child is not one of our own pipe children */
	2379
	2380	#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
	2381
	2382	/* waitpid() became available in the CRTL as of VMS 7.0, but only
	2383	* in 7.2 did we get a version that fills in the VMS completion
	2384	* status as Perl has always tried to do.
	2385	*/
	2386
	2387	sts = __vms_waitpid( pid, statusp, flags );
	2388
	2389	if ( sts == 0 \|\| !(sts == -1 && errno == ECHILD) )
	2390	return sts;
	2391
	2392	/* If the real waitpid tells us the child does not exist, we
	2393	* fall through here to implement waiting for a child that
	2394	* was created by some means other than exec() (say, spawned
	2395	* from DCL) or to wait for a process that is not a subprocess
	2396	* of the current process.
	2397	*/
	2398
	2399	#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
	2400
	2401	$DESCRIPTOR(intdsc,"0 00:00:01");
	2402	unsigned long int ownercode = JPI$_OWNER, ownerpid;
	2403	unsigned long int pidcode = JPI$_PID, mypid;
	2404	unsigned long int interval[2];
	2405	int termination_mbu = 0;
	2406	unsigned short qio_iosb[4];
	2407	unsigned int jpi_iosb[2];
	2408	struct itmlst_3 jpilist[3] = {
	2409	{sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
	2410	{sizeof(termination_mbu), JPI$_TMBU, &termination_mbu, 0},
	2411	{ 0, 0, 0, 0}
	2412	};
	2413	char trmmbx[NAM$C_DVI+1];
	2414	$DESCRIPTOR(trmmbxdsc,trmmbx);
	2415	struct accdef trmmsg;
	2416	unsigned short int mbxchan;
	2417
	2418	if (pid <= 0) {
	2419	/* Sorry folks, we don't presently implement rooting around for
	2420	the first child we can find, and we definitely don't want to
	2421	pass a pid of -1 to $getjpi, where it is a wildcard operation.
	2422	*/
	2423	set_errno(ENOTSUP);
	2424	return -1;
	2425	}
	2426
	2427	/* Get the owner of the child so I can warn if it's not mine, plus
	2428	* get the termination mailbox. If the process doesn't exist or I
	2429	* don't have the privs to look at it, I can go home early.
	2430	*/
	2431	sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
	2432	if (sts & 1) sts = jpi_iosb[0];
	2433	if (!(sts & 1)) {
	2434	switch (sts) {
	2435	case SS$_NONEXPR:
	2436	set_errno(ECHILD);
	2437	break;
	2438	case SS$_NOPRIV:
	2439	set_errno(EACCES);
	2440	break;
	2441	default:
	2442	_ckvmssts(sts);
	2443	}
	2444	set_vaxc_errno(sts);
	2445	return -1;
	2446	}
	2447
	2448	if (ckWARN(WARN_EXEC)) {
	2449	/* remind folks they are asking for non-standard waitpid behavior */
	2450	_ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
	2451	if (ownerpid != mypid)
	2452	Perl_warner(aTHX_ WARN_EXEC,
	2453	"waitpid: process %x is not a child of process %x",
	2454	pid,mypid);
	2455	}
	2456
	2457	/* It's possible to have a mailbox unit number but no actual mailbox; we
	2458	* check for this by assigning a channel to it, which we need anyway.
	2459	*/
	2460	if (termination_mbu != 0) {
	2461	sprintf(trmmbx, "MBA%d:", termination_mbu);
	2462	trmmbxdsc.dsc$w_length = strlen(trmmbx);
	2463	sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
	2464	if (sts == SS$_NOSUCHDEV) {
	2465	termination_mbu = 0; /* set up to take "no mailbox" case */
	2466	sts = SS$_NORMAL;
	2467	}
	2468	_ckvmssts(sts);
	2469	}
	2470	/* If the process doesn't have a termination mailbox, then simply check
	2471	* on it once a second until it's not there anymore.
	2472	*/
	2473	if (termination_mbu == 0) {
	2474	_ckvmssts(sys$bintim(&intdsc,interval));
	2475	while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
	2476	_ckvmssts(sys$schdwk(0,0,interval,0));
	2477	_ckvmssts(sys$hiber());
	2478	}
	2479	if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
	2480	}
	2481	else {
	2482	/* If we do have a termination mailbox, post reads to it until we get a
	2483	* termination message, discarding messages of the wrong type or for other
	2484	* processes. If there is a place to put the final status, then do so.
	2485	*/
	2486	sts = SS$_NORMAL;
	2487	while (sts & 1) {
	2488	memset((void *) &trmmsg, 0, sizeof(trmmsg));
	2489	sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
	2490	&trmmsg,ACC$K_TERMLEN,0,0,0,0);
	2491	if (sts & 1) sts = qio_iosb[0];
	2492
	2493	if ( sts & 1
	2494	&& trmmsg.acc$w_msgtyp == MSG$_DELPROC
	2495	&& trmmsg.acc$l_pid == pid ) {
	2496
	2497	if (statusp) *statusp = trmmsg.acc$l_finalsts;
	2498	sts = sys$dassgn(mbxchan);
	2499	break;
	2500	}
	2501	}
	2502	} /* termination_mbu ? */
	2503
	2504	_ckvmssts(sts);
	2505	return pid;
	2506
	2507	} /* else one of our own pipe children */
	2508
	2509	} /* end of waitpid() */
	2510	/}}}/
	2511	/}}}/
	2512	/}}}/
	2513
	2514	/{{{ char my_gconvert(double val, int ndig, int trail, char buf) /
	2515	char *
	2516	my_gconvert(double val, int ndig, int trail, char *buf)
	2517	{
	2518	static char __gcvtbuf[DBL_DIG+1];
	2519	char *loc;
	2520
	2521	loc = buf ? buf : __gcvtbuf;
	2522
	2523	#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
	2524	if (val < 1) {
	2525	sprintf(loc,"%.*g",ndig,val);
	2526	return loc;
	2527	}
	2528	#endif
	2529
	2530	if (val) {
	2531	if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
	2532	return gcvt(val,ndig,loc);
	2533	}
	2534	else {
	2535	loc[0] = '0'; loc[1] = '\0';
	2536	return loc;
	2537	}
	2538
	2539	}
	2540	/}}}/
	2541
	2542
	2543	/{{{char do_rmsexpand(char fspec, char out, int ts, char def, unsigned opts)/
	2544	/* Shortcut for common case of simple calls to $PARSE and $SEARCH
	2545	* to expand file specification. Allows for a single default file
	2546	* specification and a simple mask of options. If outbuf is non-NULL,
	2547	* it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
	2548	* the resultant file specification is placed. If outbuf is NULL, the
	2549	* resultant file specification is placed into a static buffer.
	2550	* The third argument, if non-NULL, is taken to be a default file
	2551	* specification string. The fourth argument is unused at present.
	2552	* rmesexpand() returns the address of the resultant string if
	2553	* successful, and NULL on error.
	2554	*/
	2555	static char mp_do_tounixspec(pTHX_ char , char *, int);
	2556
	2557	static char *
	2558	mp_do_rmsexpand(pTHX_ char filespec, char outbuf, int ts, char *defspec, unsigned opts)
	2559	{
	2560	static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
	2561	char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
	2562	char esa[NAM$C_MAXRSS], cp, out = NULL;
	2563	struct FAB myfab = cc$rms_fab;
	2564	struct NAM mynam = cc$rms_nam;
	2565	STRLEN speclen;
	2566	unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
	2567
	2568	if (!filespec \|\| !*filespec) {
	2569	set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
	2570	return NULL;
	2571	}
	2572	if (!outbuf) {
	2573	if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
	2574	else outbuf = __rmsexpand_retbuf;
	2575	}
	2576	if ((isunix = (strchr(filespec,'/') != NULL))) {
	2577	if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
	2578	filespec = vmsfspec;
	2579	}
	2580
	2581	myfab.fab$l_fna = filespec;
	2582	myfab.fab$b_fns = strlen(filespec);
	2583	myfab.fab$l_nam = &mynam;
	2584
	2585	if (defspec && *defspec) {
	2586	if (strchr(defspec,'/') != NULL) {
	2587	if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
	2588	defspec = tmpfspec;
	2589	}
	2590	myfab.fab$l_dna = defspec;
	2591	myfab.fab$b_dns = strlen(defspec);
	2592	}
	2593
	2594	mynam.nam$l_esa = esa;
	2595	mynam.nam$b_ess = sizeof esa;
	2596	mynam.nam$l_rsa = outbuf;
	2597	mynam.nam$b_rss = NAM$C_MAXRSS;
	2598
	2599	retsts = sys$parse(&myfab,0,0);
	2600	if (!(retsts & 1)) {
	2601	mynam.nam$b_nop \|= NAM$M_SYNCHK;
	2602	if (retsts == RMS$_DNF \|\| retsts == RMS$_DIR \|\| retsts == RMS$_DEV) {
	2603	retsts = sys$parse(&myfab,0,0);
	2604	if (retsts & 1) goto expanded;
	2605	}
	2606	mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
	2607	(void) sys$parse(&myfab,0,0); /* Free search context */
	2608	if (out) Safefree(out);
	2609	set_vaxc_errno(retsts);
	2610	if (retsts == RMS$_PRV) set_errno(EACCES);
	2611	else if (retsts == RMS$_DEV) set_errno(ENODEV);
	2612	else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
	2613	else set_errno(EVMSERR);
	2614	return NULL;
	2615	}
	2616	retsts = sys$search(&myfab,0,0);
	2617	if (!(retsts & 1) && retsts != RMS$_FNF) {
	2618	mynam.nam$b_nop \|= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
	2619	myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
	2620	if (out) Safefree(out);
	2621	set_vaxc_errno(retsts);
	2622	if (retsts == RMS$_PRV) set_errno(EACCES);
	2623	else set_errno(EVMSERR);
	2624	return NULL;
	2625	}
	2626
	2627	/* If the input filespec contained any lowercase characters,
	2628	* downcase the result for compatibility with Unix-minded code. */
	2629	expanded:
	2630	for (out = myfab.fab$l_fna; *out; out++)
	2631	if (islower(*out)) { haslower = 1; break; }
	2632	if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
	2633	else { out = esa; speclen = mynam.nam$b_esl; }
	2634	/* Trim off null fields added by $PARSE
	2635	* If type > 1 char, must have been specified in original or default spec
	2636	* (not true for version; $SEARCH may have added version of existing file).
	2637	*/
	2638	trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
	2639	trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
	2640	(mynam.nam$l_ver - mynam.nam$l_type == 1);
	2641	if (trimver \|\| trimtype) {
	2642	if (defspec && *defspec) {
	2643	char defesa[NAM$C_MAXRSS];
	2644	struct FAB deffab = cc$rms_fab;
	2645	struct NAM defnam = cc$rms_nam;
	2646
	2647	deffab.fab$l_nam = &defnam;
	2648	deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
	2649	defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
	2650	defnam.nam$b_nop = NAM$M_SYNCHK;
	2651	if (sys$parse(&deffab,0,0) & 1) {
	2652	if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
	2653	if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
	2654	}
	2655	}
	2656	if (trimver) speclen = mynam.nam$l_ver - out;
	2657	if (trimtype) {
	2658	/* If we didn't already trim version, copy down */
	2659	if (speclen > mynam.nam$l_ver - out)
	2660	memcpy(mynam.nam$l_type, mynam.nam$l_ver,
	2661	speclen - (mynam.nam$l_ver - out));
	2662	speclen -= mynam.nam$l_ver - mynam.nam$l_type;
	2663	}
	2664	}
	2665	/* If we just had a directory spec on input, $PARSE "helpfully"
	2666	* adds an empty name and type for us */
	2667	if (mynam.nam$l_name == mynam.nam$l_type &&
	2668	mynam.nam$l_ver == mynam.nam$l_type + 1 &&
	2669	!(mynam.nam$l_fnb & NAM$M_EXP_NAME))
	2670	speclen = mynam.nam$l_name - out;
	2671	out[speclen] = '\0';
	2672	if (haslower) __mystrtolower(out);
	2673
	2674	/* Have we been working with an expanded, but not resultant, spec? */
	2675	/* Also, convert back to Unix syntax if necessary. */
	2676	if (!mynam.nam$b_rsl) {
	2677	if (isunix) {
	2678	if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
	2679	}
	2680	else strcpy(outbuf,esa);
	2681	}
	2682	else if (isunix) {
	2683	if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
	2684	strcpy(outbuf,tmpfspec);
	2685	}
	2686	mynam.nam$b_nop \|= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
	2687	mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
	2688	myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
	2689	return outbuf;
	2690	}
	2691	/}}}/
	2692	/* External entry points */
	2693	char Perl_rmsexpand(pTHX_ char spec, char buf, char def, unsigned opt)
	2694	{ return do_rmsexpand(spec,buf,0,def,opt); }
	2695	char Perl_rmsexpand_ts(pTHX_ char spec, char buf, char def, unsigned opt)
	2696	{ return do_rmsexpand(spec,buf,1,def,opt); }
	2697
	2698
	2699	/*
	2700	** The following routines are provided to make life easier when
	2701	** converting among VMS-style and Unix-style directory specifications.
	2702	** All will take input specifications in either VMS or Unix syntax. On
	2703	** failure, all return NULL. If successful, the routines listed below
	2704	** return a pointer to a buffer containing the appropriately
	2705	** reformatted spec (and, therefore, subsequent calls to that routine
	2706	** will clobber the result), while the routines of the same names with
	2707	** a _ts suffix appended will return a pointer to a mallocd string
	2708	** containing the appropriately reformatted spec.
	2709	** In all cases, only explicit syntax is altered; no check is made that
	2710	** the resulting string is valid or that the directory in question
	2711	** actually exists.
	2712	**
	2713	** fileify_dirspec() - convert a directory spec into the name of the
	2714	** directory file (i.e. what you can stat() to see if it's a dir).
	2715	** The style (VMS or Unix) of the result is the same as the style
	2716	** of the parameter passed in.
	2717	** pathify_dirspec() - convert a directory spec into a path (i.e.
	2718	** what you prepend to a filename to indicate what directory it's in).
	2719	** The style (VMS or Unix) of the result is the same as the style
	2720	** of the parameter passed in.
	2721	** tounixpath() - convert a directory spec into a Unix-style path.
	2722	** tovmspath() - convert a directory spec into a VMS-style path.
	2723	** tounixspec() - convert any file spec into a Unix-style file spec.
	2724	** tovmsspec() - convert any file spec into a VMS-style spec.
	2725	**
	2726	** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
	2727	** Permission is given to distribute this code as part of the Perl
	2728	** standard distribution under the terms of the GNU General Public
	2729	** License or the Perl Artistic License. Copies of each may be
	2730	** found in the Perl standard distribution.
	2731	*/
	2732
	2733	/{{{ char fileify_dirspec[_ts](char path, char buf)*/
	2734	static char mp_do_fileify_dirspec(pTHX_ char dir,char *buf,int ts)
	2735	{
	2736	static char __fileify_retbuf[NAM$C_MAXRSS+1];
	2737	unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
	2738	char retspec, cp1, cp2, lastdir;
	2739	char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
	2740
	2741	if (!dir \|\| !*dir) {
	2742	set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
	2743	}
	2744	dirlen = strlen(dir);
	2745	while (dirlen && dir[dirlen-1] == '/') --dirlen;
	2746	if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
	2747	strcpy(trndir,"/sys$disk/000000");
	2748	dir = trndir;
	2749	dirlen = 16;
	2750	}
	2751	if (dirlen > NAM$C_MAXRSS) {
	2752	set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
	2753	}
	2754	if (!strpbrk(dir+1,"/]>:")) {
	2755	strcpy(trndir,*dir == '/' ? dir + 1: dir);
	2756	while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
	2757	dir = trndir;
	2758	dirlen = strlen(dir);
	2759	}
	2760	else {
	2761	strncpy(trndir,dir,dirlen);
	2762	trndir[dirlen] = '\0';
	2763	dir = trndir;
	2764	}
	2765	/* If we were handed a rooted logical name or spec, treat it like a
	2766	* simple directory, so that
	2767	* $ Define myroot dev:[dir.]
	2768	* ... do_fileify_dirspec("myroot",buf,1) ...
	2769	* does something useful.
	2770	*/
	2771	if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
	2772	dir[--dirlen] = '\0';
	2773	dir[dirlen-1] = ']';
	2774	}
	2775	if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
	2776	dir[--dirlen] = '\0';
	2777	dir[dirlen-1] = '>';
	2778	}
	2779
	2780	if ((cp1 = strrchr(dir,']')) != NULL \|\| (cp1 = strrchr(dir,'>')) != NULL) {
	2781	/* If we've got an explicit filename, we can just shuffle the string. */
	2782	if (*(cp1+1)) hasfilename = 1;
	2783	/* Similarly, we can just back up a level if we've got multiple levels
	2784	of explicit directories in a VMS spec which ends with directories. */
	2785	else {
	2786	for (cp2 = cp1; cp2 > dir; cp2--) {
	2787	if (*cp2 == '.') {
	2788	cp2 = cp1; *cp1 = '\0';
	2789	hasfilename = 1;
	2790	break;
	2791	}
	2792	if (cp2 == '[' \|\| cp2 == '<') break;
	2793	}
	2794	}
	2795	}
	2796
	2797	if (hasfilename \|\| !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
	2798	if (dir[0] == '.') {
	2799	if (dir[1] == '\0' \|\| (dir[1] == '/' && dir[2] == '\0'))
	2800	return do_fileify_dirspec("[]",buf,ts);
	2801	else if (dir[1] == '.' &&
	2802	(dir[2] == '\0' \|\| (dir[2] == '/' && dir[3] == '\0')))
	2803	return do_fileify_dirspec("[-]",buf,ts);
	2804	}
	2805	if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
	2806	dirlen -= 1; /* to last element */
	2807	lastdir = strrchr(dir,'/');
	2808	}
	2809	else if ((cp1 = strstr(dir,"/.")) != NULL) {
	2810	/* If we have "/." or "/..", VMSify it and let the VMS code
	2811	* below expand it, rather than repeating the code to handle
	2812	* relative components of a filespec here */
	2813	do {
	2814	if (*(cp1+2) == '.') cp1++;
	2815	if ((cp1+2) == '/' \|\| (cp1+2) == '\0') {
	2816	if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
	2817	if (strchr(vmsdir,'/') != NULL) {
	2818	/* If do_tovmsspec() returned it, it must have VMS syntax
	2819	* delimiters in it, so it's a mixed VMS/Unix spec. We take
	2820	* the time to check this here only so we avoid a recursion
	2821	* loop; otherwise, gigo.
	2822	*/
	2823	set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
	2824	}
	2825	if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
	2826	return do_tounixspec(trndir,buf,ts);
	2827	}
	2828	cp1++;
	2829	} while ((cp1 = strstr(cp1,"/.")) != NULL);
	2830	lastdir = strrchr(dir,'/');
	2831	}
	2832	else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
	2833	/* Ditto for specs that end in an MFD -- let the VMS code
	2834	* figure out whether it's a real device or a rooted logical. */
	2835	dir[dirlen] = '/'; dir[dirlen+1] = '\0';
	2836	if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
	2837	if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
	2838	return do_tounixspec(trndir,buf,ts);
	2839	}
	2840	else {
	2841	if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
	2842	!(lastdir = cp1 = strrchr(dir,']')) &&
	2843	!(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
	2844	if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
	2845	int ver; char *cp3;
	2846	if (!(cp2+1) \|\| toupper((cp2+1)) != 'D' \|\| /* Wrong type. */
	2847	!(cp2+2) \|\| toupper((cp2+2)) != 'I' \|\| /* Bzzt. */
	2848	!(cp2+3) \|\| toupper((cp2+3)) != 'R' \|\|
	2849	((cp2+4) && (((cp2+4) != ';' && *(cp2+4) != '.') \|\|
	2850	(*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
	2851	(ver \|\| *cp3)))))) {
	2852	set_errno(ENOTDIR);
	2853	set_vaxc_errno(RMS$_DIR);
	2854	return NULL;
	2855	}
	2856	dirlen = cp2 - dir;
	2857	}
	2858	}
	2859	/* If we lead off with a device or rooted logical, add the MFD
	2860	if we're specifying a top-level directory. */
	2861	if (lastdir && *dir == '/') {
	2862	addmfd = 1;
	2863	for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
	2864	if (*cp1 == '/') {
	2865	addmfd = 0;
	2866	break;
	2867	}
	2868	}
	2869	}
	2870	retlen = dirlen + (addmfd ? 13 : 6);
	2871	if (buf) retspec = buf;
	2872	else if (ts) New(1309,retspec,retlen+1,char);
	2873	else retspec = __fileify_retbuf;
	2874	if (addmfd) {
	2875	dirlen = lastdir - dir;
	2876	memcpy(retspec,dir,dirlen);
	2877	strcpy(&retspec[dirlen],"/000000");
	2878	strcpy(&retspec[dirlen+7],lastdir);
	2879	}
	2880	else {
	2881	memcpy(retspec,dir,dirlen);
	2882	retspec[dirlen] = '\0';
	2883	}
	2884	/* We've picked up everything up to the directory file name.
	2885	Now just add the type and version, and we're set. */
	2886	strcat(retspec,".dir;1");
	2887	return retspec;
	2888	}
	2889	else { /* VMS-style directory spec */
	2890	char esa[NAM$C_MAXRSS+1], term, *cp;
	2891	unsigned long int sts, cmplen, haslower = 0;
	2892	struct FAB dirfab = cc$rms_fab;
	2893	struct NAM savnam, dirnam = cc$rms_nam;
	2894
	2895	dirfab.fab$b_fns = strlen(dir);
	2896	dirfab.fab$l_fna = dir;
	2897	dirfab.fab$l_nam = &dirnam;
	2898	dirfab.fab$l_dna = ".DIR;1";
	2899	dirfab.fab$b_dns = 6;
	2900	dirnam.nam$b_ess = NAM$C_MAXRSS;
	2901	dirnam.nam$l_esa = esa;
	2902
	2903	for (cp = dir; *cp; cp++)
	2904	if (islower(*cp)) { haslower = 1; break; }
	2905	if (!((sts = sys$parse(&dirfab))&1)) {
	2906	if (dirfab.fab$l_sts == RMS$_DIR) {
	2907	dirnam.nam$b_nop \|= NAM$M_SYNCHK;
	2908	sts = sys$parse(&dirfab) & 1;
	2909	}
	2910	if (!sts) {
	2911	set_errno(EVMSERR);
	2912	set_vaxc_errno(dirfab.fab$l_sts);
	2913	return NULL;
	2914	}
	2915	}
	2916	else {
	2917	savnam = dirnam;
	2918	if (sys$search(&dirfab)&1) { /* Does the file really exist? */
	2919	/* Yes; fake the fnb bits so we'll check type below */
	2920	dirnam.nam$l_fnb \|= NAM$M_EXP_TYPE \| NAM$M_EXP_VER;
	2921	}
	2922	else { /* No; just work with potential name */
	2923	if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
	2924	else {
	2925	set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
	2926	dirnam.nam$b_nop \|= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
	2927	dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
	2928	return NULL;
	2929	}
	2930	}
	2931	}
	2932	if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV \| NAM$M_EXP_DIR))) {
	2933	cp1 = strchr(esa,']');
	2934	if (!cp1) cp1 = strchr(esa,'>');
	2935	if (cp1) { /* Should always be true */
	2936	dirnam.nam$b_esl -= cp1 - esa - 1;
	2937	memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
	2938	}
	2939	}
	2940	if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
	2941	/* Yep; check version while we're at it, if it's there. */
	2942	cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
	2943	if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
	2944	/* Something other than .DIR[;1]. Bzzt. */
	2945	dirnam.nam$b_nop \|= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
	2946	dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
	2947	set_errno(ENOTDIR);
	2948	set_vaxc_errno(RMS$_DIR);
	2949	return NULL;
	2950	}
	2951	}
	2952	esa[dirnam.nam$b_esl] = '\0';
	2953	if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
	2954	/* They provided at least the name; we added the type, if necessary, */
	2955	if (buf) retspec = buf; /* in sys$parse() */
	2956	else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
	2957	else retspec = __fileify_retbuf;
	2958	strcpy(retspec,esa);
	2959	dirnam.nam$b_nop \|= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
	2960	dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
	2961	return retspec;
	2962	}
	2963	if ((cp1 = strstr(esa,".][000000]")) != NULL) {
	2964	for (cp2 = cp1 + 9; cp2; cp1++,cp2++) cp1 = *cp2;
	2965	*cp1 = '\0';
	2966	dirnam.nam$b_esl -= 9;
	2967	}
	2968	if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
	2969	if (cp1 == NULL) { /* should never happen */
	2970	dirnam.nam$b_nop \|= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
	2971	dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
	2972	return NULL;
	2973	}
	2974	term = *cp1;
	2975	*cp1 = '\0';
	2976	retlen = strlen(esa);
	2977	if ((cp1 = strrchr(esa,'.')) != NULL) {
	2978	/* There's more than one directory in the path. Just roll back. */
	2979	*cp1 = term;
	2980	if (buf) retspec = buf;
	2981	else if (ts) New(1311,retspec,retlen+7,char);
	2982	else retspec = __fileify_retbuf;
	2983	strcpy(retspec,esa);
	2984	}
	2985	else {
	2986	if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
	2987	/* Go back and expand rooted logical name */
	2988	dirnam.nam$b_nop = NAM$M_SYNCHK \| NAM$M_NOCONCEAL;
	2989	if (!(sys$parse(&dirfab) & 1)) {
	2990	dirnam.nam$l_rlf = NULL;
	2991	dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
	2992	set_errno(EVMSERR);
	2993	set_vaxc_errno(dirfab.fab$l_sts);
	2994	return NULL;
	2995	}
	2996	retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
	2997	if (buf) retspec = buf;
	2998	else if (ts) New(1312,retspec,retlen+16,char);
	2999	else retspec = __fileify_retbuf;
	3000	cp1 = strstr(esa,"][");
	3001	if (!cp1) cp1 = strstr(esa,"]<");
	3002	dirlen = cp1 - esa;
	3003	memcpy(retspec,esa,dirlen);
	3004	if (!strncmp(cp1+2,"000000]",7)) {
	3005	retspec[dirlen-1] = '\0';
	3006	for (cp1 = retspec+dirlen-1; cp1 != '.' && cp1 != '['; cp1--) ;
	3007	if (cp1 == '.') cp1 = ']';
	3008	else {
	3009	memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
	3010	memcpy(cp1+1,"000000]",7);
	3011	}
	3012	}
	3013	else {
	3014	memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
	3015	retspec[retlen] = '\0';
	3016	/* Convert last '.' to ']' */
	3017	for (cp1 = retspec+retlen-1; cp1 != '.' && cp1 != '['; cp1--) ;
	3018	if (cp1 == '.') cp1 = ']';
	3019	else {
	3020	memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
	3021	memcpy(cp1+1,"000000]",7);
	3022	}
	3023	}
	3024	}
	3025	else { /* This is a top-level dir. Add the MFD to the path. */
	3026	if (buf) retspec = buf;
	3027	else if (ts) New(1312,retspec,retlen+16,char);
	3028	else retspec = __fileify_retbuf;
	3029	cp1 = esa;
	3030	cp2 = retspec;
	3031	while (cp1 != ':') (cp2++) = *(cp1++);
	3032	strcpy(cp2,":[000000]");
	3033	cp1 += 2;
	3034	strcpy(cp2+9,cp1);
	3035	}
	3036	}
	3037	dirnam.nam$b_nop \|= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
	3038	dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
	3039	/* We've set up the string up through the filename. Add the
	3040	type and version, and we're done. */
	3041	strcat(retspec,".DIR;1");
	3042
	3043	/* $PARSE may have upcased filespec, so convert output to lower
	3044	* case if input contained any lowercase characters. */
	3045	if (haslower) __mystrtolower(retspec);
	3046	return retspec;
	3047	}
	3048	} /* end of do_fileify_dirspec() */
	3049	/}}}/
	3050	/* External entry points */
	3051	char Perl_fileify_dirspec(pTHX_ char dir, char *buf)
	3052	{ return do_fileify_dirspec(dir,buf,0); }
	3053	char Perl_fileify_dirspec_ts(pTHX_ char dir, char *buf)
	3054	{ return do_fileify_dirspec(dir,buf,1); }
	3055
	3056	/{{{ char pathify_dirspec[_ts](char path, char buf)*/
	3057	static char mp_do_pathify_dirspec(pTHX_ char dir,char *buf, int ts)
	3058	{
	3059	static char __pathify_retbuf[NAM$C_MAXRSS+1];
	3060	unsigned long int retlen;
	3061	char retpath, cp1, *cp2, trndir[NAM$C_MAXRSS+1];
	3062
	3063	if (!dir \|\| !*dir) {
	3064	set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
	3065	}
	3066
	3067	if (*dir) strcpy(trndir,dir);
	3068	else getcwd(trndir,sizeof trndir - 1);
	3069
	3070	while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
	3071	&& my_trnlnm(trndir,trndir,0)) {
	3072	STRLEN trnlen = strlen(trndir);
	3073
	3074	/* Trap simple rooted lnms, and return lnm:[000000] */
	3075	if (!strcmp(trndir+trnlen-2,".]")) {
	3076	if (buf) retpath = buf;
	3077	else if (ts) New(1318,retpath,strlen(dir)+10,char);
	3078	else retpath = __pathify_retbuf;
	3079	strcpy(retpath,dir);
	3080	strcat(retpath,":[000000]");
	3081	return retpath;
	3082	}
	3083	}
	3084	dir = trndir;
	3085
	3086	if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
	3087	if (dir == '.' && ((dir+1) == '\0' \|\|
	3088	((dir+1) == '.' && (dir+2) == '\0')))
	3089	retlen = 2 + (*(dir+1) != '\0');
	3090	else {
	3091	if ( !(cp1 = strrchr(dir,'/')) &&
	3092	!(cp1 = strrchr(dir,']')) &&
	3093	!(cp1 = strrchr(dir,'>')) ) cp1 = dir;
	3094	if ((cp2 = strchr(cp1,'.')) != NULL &&
	3095	((cp2-1) != '/' \|\| / Trailing '.', '..', */
	3096	!((cp2+1) == '\0' \|\| / or '...' are dirs. */
	3097	((cp2+1) == '.' && (cp2+2) == '\0') \|\|
	3098	((cp2+1) == '.' && (cp2+2) == '.' && *(cp2+3) == '\0')))) {
	3099	int ver; char *cp3;
	3100	if (!(cp2+1) \|\| toupper((cp2+1)) != 'D' \|\| /* Wrong type. */
	3101	!(cp2+2) \|\| toupper((cp2+2)) != 'I' \|\| /* Bzzt. */
	3102	!(cp2+3) \|\| toupper((cp2+3)) != 'R' \|\|
	3103	((cp2+4) && (((cp2+4) != ';' && *(cp2+4) != '.') \|\|
	3104	(*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
	3105	(ver \|\| *cp3)))))) {
	3106	set_errno(ENOTDIR);
	3107	set_vaxc_errno(RMS$_DIR);
	3108	return NULL;
	3109	}
	3110	retlen = cp2 - dir + 1;
	3111	}
	3112	else { /* No file type present. Treat the filename as a directory. */
	3113	retlen = strlen(dir) + 1;
	3114	}
	3115	}
	3116	if (buf) retpath = buf;
	3117	else if (ts) New(1313,retpath,retlen+1,char);
	3118	else retpath = __pathify_retbuf;
	3119	strncpy(retpath,dir,retlen-1);
	3120	if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
	3121	retpath[retlen-1] = '/'; /* with '/', add it. */
	3122	retpath[retlen] = '\0';
	3123	}
	3124	else retpath[retlen-1] = '\0';
	3125	}
	3126	else { /* VMS-style directory spec */
	3127	char esa[NAM$C_MAXRSS+1], *cp;
	3128	unsigned long int sts, cmplen, haslower;
	3129	struct FAB dirfab = cc$rms_fab;
	3130	struct NAM savnam, dirnam = cc$rms_nam;
	3131
	3132	/* If we've got an explicit filename, we can just shuffle the string. */
	3133	if ( ( (cp1 = strrchr(dir,']')) != NULL \|\|
	3134	(cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
	3135	if ((cp2 = strchr(cp1,'.')) != NULL) {
	3136	int ver; char *cp3;
	3137	if (!(cp2+1) \|\| toupper((cp2+1)) != 'D' \|\| /* Wrong type. */
	3138	!(cp2+2) \|\| toupper((cp2+2)) != 'I' \|\| /* Bzzt. */
	3139	!(cp2+3) \|\| toupper((cp2+3)) != 'R' \|\|
	3140	((cp2+4) && (((cp2+4) != ';' && *(cp2+4) != '.') \|\|
	3141	(*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
	3142	(ver \|\| *cp3)))))) {
	3143	set_errno(ENOTDIR);
	3144	set_vaxc_errno(RMS$_DIR);
	3145	return NULL;
	3146	}
	3147	}
	3148	else { /* No file type, so just draw name into directory part */
	3149	for (cp2 = cp1; *cp2; cp2++) ;
	3150	}
	3151	cp2 = cp1;
	3152	(cp2+1) = '\0'; / OK; trndir is guaranteed to be long enough */
	3153	*cp1 = '.';
	3154	/* We've now got a VMS 'path'; fall through */
	3155	}
	3156	dirfab.fab$b_fns = strlen(dir);
	3157	dirfab.fab$l_fna = dir;
	3158	if (dir[dirfab.fab$b_fns-1] == ']' \|\|
	3159	dir[dirfab.fab$b_fns-1] == '>' \|\|
	3160	dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
	3161	if (buf) retpath = buf;
	3162	else if (ts) New(1314,retpath,strlen(dir)+1,char);
	3163	else retpath = __pathify_retbuf;
	3164	strcpy(retpath,dir);
	3165	return retpath;
	3166	}
	3167	dirfab.fab$l_dna = ".DIR;1";
	3168	dirfab.fab$b_dns = 6;
	3169	dirfab.fab$l_nam = &dirnam;
	3170	dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
	3171	dirnam.nam$l_esa = esa;
	3172
	3173	for (cp = dir; *cp; cp++)
	3174	if (islower(*cp)) { haslower = 1; break; }
	3175
	3176	if (!(sts = (sys$parse(&dirfab)&1))) {
	3177	if (dirfab.fab$l_sts == RMS$_DIR) {
	3178	dirnam.nam$b_nop \|= NAM$M_SYNCHK;
	3179	sts = sys$parse(&dirfab) & 1;
	3180	}
	3181	if (!sts) {
	3182	set_errno(EVMSERR);
	3183	set_vaxc_errno(dirfab.fab$l_sts);
	3184	return NULL;
	3185	}
	3186	}
	3187	else {
	3188	savnam = dirnam;
	3189	if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
	3190	if (dirfab.fab$l_sts != RMS$_FNF) {
	3191	dirnam.nam$b_nop \|= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
	3192	dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
	3193	set_errno(EVMSERR);
	3194	set_vaxc_errno(dirfab.fab$l_sts);
	3195	return NULL;
	3196	}
	3197	dirnam = savnam; /* No; just work with potential name */
	3198	}
	3199	}
	3200	if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
	3201	/* Yep; check version while we're at it, if it's there. */
	3202	cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
	3203	if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
	3204	/* Something other than .DIR[;1]. Bzzt. */
	3205	dirnam.nam$b_nop \|= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
	3206	dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
	3207	set_errno(ENOTDIR);
	3208	set_vaxc_errno(RMS$_DIR);
	3209	return NULL;
	3210	}
	3211	}
	3212	/* OK, the type was fine. Now pull any file name into the
	3213	directory path. */
	3214	if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
	3215	else {
	3216	cp1 = strrchr(esa,'>');
	3217	*dirnam.nam$l_type = '>';
	3218	}
	3219	*cp1 = '.';
	3220	*(dirnam.nam$l_type + 1) = '\0';
	3221	retlen = dirnam.nam$l_type - esa + 2;
	3222	if (buf) retpath = buf;
	3223	else if (ts) New(1314,retpath,retlen,char);
	3224	else retpath = __pathify_retbuf;
	3225	strcpy(retpath,esa);
	3226	dirnam.nam$b_nop \|= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
	3227	dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
	3228	/* $PARSE may have upcased filespec, so convert output to lower
	3229	* case if input contained any lowercase characters. */
	3230	if (haslower) __mystrtolower(retpath);
	3231	}
	3232
	3233	return retpath;
	3234	} /* end of do_pathify_dirspec() */
	3235	/}}}/
	3236	/* External entry points */
	3237	char Perl_pathify_dirspec(pTHX_ char dir, char *buf)
	3238	{ return do_pathify_dirspec(dir,buf,0); }
	3239	char Perl_pathify_dirspec_ts(pTHX_ char dir, char *buf)
	3240	{ return do_pathify_dirspec(dir,buf,1); }
	3241
	3242	/{{{ char tounixspec[_ts](char path, char buf)*/
	3243	static char mp_do_tounixspec(pTHX_ char spec, char *buf, int ts)
	3244	{
	3245	static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
	3246	char dirend, rslt, cp1, cp2, *cp3, tmp[NAM$C_MAXRSS+1];
	3247	int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
	3248
	3249	if (spec == NULL) return NULL;
	3250	if (strlen(spec) > NAM$C_MAXRSS) return NULL;
	3251	if (buf) rslt = buf;
	3252	else if (ts) {
	3253	retlen = strlen(spec);
	3254	cp1 = strchr(spec,'[');
	3255	if (!cp1) cp1 = strchr(spec,'<');
	3256	if (cp1) {
	3257	for (cp1++; *cp1; cp1++) {
	3258	if (cp1 == '-') expand++; / VMS '-' ==> Unix '../' */
	3259	if (cp1 == '.' && (cp1+1) == '.' && *(cp1+2) == '.')
	3260	{ expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
	3261	}
	3262	}
	3263	New(1315,rslt,retlen+2+2*expand,char);
	3264	}
	3265	else rslt = __tounixspec_retbuf;
	3266	if (strchr(spec,'/') != NULL) {
	3267	strcpy(rslt,spec);
	3268	return rslt;
	3269	}
	3270
	3271	cp1 = rslt;
	3272	cp2 = spec;
	3273	dirend = strrchr(spec,']');
	3274	if (dirend == NULL) dirend = strrchr(spec,'>');
	3275	if (dirend == NULL) dirend = strchr(spec,':');
	3276	if (dirend == NULL) {
	3277	strcpy(rslt,spec);
	3278	return rslt;
	3279	}
	3280	if (cp2 != '[' && cp2 != '<') {
	3281	*(cp1++) = '/';
	3282	}
	3283	else { /* the VMS spec begins with directories */
	3284	cp2++;
	3285	if (cp2 == ']' \|\| cp2 == '>') {
	3286	(cp1++) = '.'; (cp1++) = '/'; *(cp1++) = '\0';
	3287	return rslt;
	3288	}
	3289	else if ( cp2 != '.' && cp2 != '-') { /* add the implied device */
	3290	if (getcwd(tmp,sizeof tmp,1) == NULL) {
	3291	if (ts) Safefree(rslt);
	3292	return NULL;
	3293	}
	3294	do {
	3295	cp3 = tmp;
	3296	while (cp3 != ':' && cp3) cp3++;
	3297	*(cp3++) = '\0';
	3298	if (strchr(cp3,']') != NULL) break;
	3299	} while (vmstrnenv(tmp,tmp,0,fildev,0));
	3300	if (ts && !buf &&
	3301	((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
	3302	retlen = devlen + dirlen;
	3303	Renew(rslt,retlen+1+2*expand,char);
	3304	cp1 = rslt;
	3305	}
	3306	cp3 = tmp;
	3307	*(cp1++) = '/';
	3308	while (*cp3) {
	3309	(cp1++) = (cp3++);
	3310	if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
	3311	}
	3312	*(cp1++) = '/';
	3313	}
	3314	else if ( *cp2 == '.') {
	3315	if ((cp2+1) == '.' && (cp2+2) == '.') {
	3316	(cp1++) = '.'; (cp1++) = '.'; (cp1++) = '.'; (cp1++) = '/';
	3317	cp2 += 3;
	3318	}
	3319	else cp2++;
	3320	}
	3321	}
	3322	for (; cp2 <= dirend; cp2++) {
	3323	if (*cp2 == ':') {
	3324	*(cp1++) = '/';
	3325	if (*(cp2+1) == '[') cp2++;
	3326	}
	3327	else if (cp2 == ']' \|\| cp2 == '>') {
	3328	if ((cp1-1) != '/') (cp1++) = '/'; /* Don't double after ellipsis */
	3329	}
	3330	else if (*cp2 == '.') {
	3331	*(cp1++) = '/';
	3332	if ((cp2+1) == ']' \|\| (cp2+1) == '>') {
	3333	while ((cp2+1) == ']' \|\| (cp2+1) == '>' \|\|
	3334	(cp2+1) == '[' \|\| (cp2+1) == '<') cp2++;
	3335	if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' \|\|
	3336	(cp2+7) == '>' \|\| (cp2+7) == '.')) cp2 += 7;
	3337	}
	3338	else if ( (cp2+1) == '.' && (cp2+2) == '.') {
	3339	(cp1++) = '.'; (cp1++) = '.'; (cp1++) = '.'; (cp1++) ='/';
	3340	cp2 += 2;
	3341	}
	3342	}
	3343	else if (*cp2 == '-') {
	3344	if ((cp2-1) == '[' \|\| (cp2-1) == '<' \|\| *(cp2-1) == '.') {
	3345	while (*cp2 == '-') {
	3346	cp2++;
	3347	(cp1++) = '.'; (cp1++) = '.'; *(cp1++) = '/';
	3348	}
	3349	if (cp2 != '.' && cp2 != ']' && cp2 != '>') { / we don't allow */
	3350	if (ts) Safefree(rslt); /* filespecs like */
	3351	set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
	3352	return NULL;
	3353	}
	3354	}
	3355	else (cp1++) = cp2;
	3356	}
	3357	else (cp1++) = cp2;
	3358	}
	3359	while (cp2) (cp1++) = *(cp2++);
	3360	*cp1 = '\0';
	3361
	3362	return rslt;
	3363
	3364	} /* end of do_tounixspec() */
	3365	/}}}/
	3366	/* External entry points */
	3367	char Perl_tounixspec(pTHX_ char spec, char *buf) { return do_tounixspec(spec,buf,0); }
	3368	char Perl_tounixspec_ts(pTHX_ char spec, char *buf) { return do_tounixspec(spec,buf,1); }
	3369
	3370	/{{{ char tovmsspec[_ts](char path, char buf)*/
	3371	static char mp_do_tovmsspec(pTHX_ char path, char *buf, int ts) {
	3372	static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
	3373	char rslt, dirend;
	3374	register char cp1, cp2;
	3375	unsigned long int infront = 0, hasdir = 1;
	3376
	3377	if (path == NULL) return NULL;
	3378	if (buf) rslt = buf;
	3379	else if (ts) New(1316,rslt,strlen(path)+9,char);
	3380	else rslt = __tovmsspec_retbuf;
	3381	if (strpbrk(path,"]:>") \|\|
	3382	(dirend = strrchr(path,'/')) == NULL) {
	3383	if (path[0] == '.') {
	3384	if (path[1] == '\0') strcpy(rslt,"[]");
	3385	else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
	3386	else strcpy(rslt,path); /* probably garbage */
	3387	}
	3388	else strcpy(rslt,path);
	3389	return rslt;
	3390	}
	3391	if ((dirend+1) == '.') { / do we have trailing "/." or "/.." or "/..."? */
	3392	if (!*(dirend+2)) dirend +=2;
	3393	if ((dirend+2) == '.' && !(dirend+3)) dirend += 3;
	3394	if ((dirend+2) == '.' && (dirend+3) == '.' && !*(dirend+4)) dirend += 4;
	3395	}
	3396	cp1 = rslt;
	3397	cp2 = path;
	3398	if (*cp2 == '/') {
	3399	char trndev[NAM$C_MAXRSS+1];
	3400	int islnm, rooted;
	3401	STRLEN trnend;
	3402
	3403	while ((cp2+1) == '/') cp2++; / Skip multiple /s */
	3404	if (!*(cp2+1)) {
	3405	if (!buf & ts) Renew(rslt,18,char);
	3406	strcpy(rslt,"sys$disk:[000000]");
	3407	return rslt;
	3408	}
	3409	while ((++cp2) != '/' && cp2) (cp1++) = cp2;
	3410	*cp1 = '\0';
	3411	islnm = my_trnlnm(rslt,trndev,0);
	3412	trnend = islnm ? strlen(trndev) - 1 : 0;
	3413	islnm = trnend ? (trndev[trnend] == ']' \|\| trndev[trnend] == '>') : 0;
	3414	rooted = islnm ? (trndev[trnend-1] == '.') : 0;
	3415	/* If the first element of the path is a logical name, determine
	3416	* whether it has to be translated so we can add more directories. */
	3417	if (!islnm \|\| rooted) {
	3418	*(cp1++) = ':';
	3419	*(cp1++) = '[';
	3420	if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
	3421	else cp2++;
	3422	}
	3423	else {
	3424	if (cp2 != dirend) {
	3425	if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
	3426	strcpy(rslt,trndev);
	3427	cp1 = rslt + trnend;
	3428	*(cp1++) = '.';
	3429	cp2++;
	3430	}
	3431	else {
	3432	*(cp1++) = ':';
	3433	hasdir = 0;
	3434	}
	3435	}
	3436	}
	3437	else {
	3438	*(cp1++) = '[';
	3439	if (*cp2 == '.') {
	3440	if ((cp2+1) == '/' \|\| (cp2+1) == '\0') {
	3441	cp2 += 2; /* skip over "./" - it's redundant */
	3442	(cp1++) = '.'; / but it does indicate a relative dirspec */
	3443	}
	3444	else if ((cp2+1) == '.' && ((cp2+2) == '/' \|\| *(cp2+2) == '\0')) {
	3445	(cp1++) = '-'; / "../" --> "-" */
	3446	cp2 += 3;
	3447	}
	3448	else if ((cp2+1) == '.' && (cp2+2) == '.' &&
	3449	((cp2+3) == '/' \|\| (cp2+3) == '\0')) {
	3450	(cp1++) = '.'; (cp1++) = '.'; (cp1++) = '.'; / ".../" --> "..." */
	3451	if (!(cp2+4)) (cp1++) = '.'; /* Simulate trailing '/' for later */
	3452	cp2 += 4;
	3453	}
	3454	if (cp2 > dirend) cp2 = dirend;
	3455	}
	3456	else *(cp1++) = '.';
	3457	}
	3458	for (; cp2 < dirend; cp2++) {
	3459	if (*cp2 == '/') {
	3460	if (*(cp2-1) == '/') continue;
	3461	if ((cp1-1) != '.') (cp1++) = '.';
	3462	infront = 0;
	3463	}
	3464	else if (!infront && *cp2 == '.') {
	3465	if (cp2+1 == dirend \|\| *(cp2+1) == '\0') { cp2++; break; }
	3466	else if ((cp2+1) == '/') cp2++; / skip over "./" - it's redundant */
	3467	else if ((cp2+1) == '.' && ((cp2+2) == '/' \|\| *(cp2+2) == '\0')) {
	3468	if ((cp1-1) == '-' \|\| (cp1-1) == '[') (cp1++) = '-'; / handle "../" */
	3469	else if ((cp1-2) == '[') (cp1-1) = '-';
	3470	else { /* back up over previous directory name */
	3471	cp1--;
	3472	while ((cp1-1) != '.' && (cp1-1) != '[') cp1--;
	3473	if (*(cp1-1) == '[') {
	3474	memcpy(cp1,"000000.",7);
	3475	cp1 += 7;
	3476	}
	3477	}
	3478	cp2 += 2;
	3479	if (cp2 == dirend) break;
	3480	}
	3481	else if ( (cp2+1) == '.' && (cp2+2) == '.' &&
	3482	((cp2+3) == '/' \|\| (cp2+3) == '\0') ) {
	3483	if ((cp1-1) != '.') (cp1++) = '.'; /* May already have 1 from '/' */
	3484	(cp1++) = '.'; (cp1++) = '.'; /* ".../" --> "..." */
	3485	if (!*(cp2+3)) {
	3486	(cp1++) = '.'; / Simulate trailing '/' */
	3487	cp2 += 2; /* for loop will incr this to == dirend */
	3488	}
	3489	else cp2 += 3; /* Trailing '/' was there, so skip it, too */
	3490	}
	3491	else (cp1++) = '_'; / fix up syntax - '.' in name not allowed */
	3492	}
	3493	else {
	3494	if (!infront && (cp1-1) == '-') (cp1++) = '.';
	3495	if (cp2 == '.') (cp1++) = '_';
	3496	else (cp1++) = cp2;
	3497	infront = 1;
	3498	}
	3499	}
	3500	if ((cp1-1) == '.') cp1--; / Unix spec ending in '/' ==> trailing '.' */
	3501	if (hasdir) *(cp1++) = ']';
	3502	if (cp2) cp2++; / check in case we ended with trailing '..' */
	3503	while (cp2) (cp1++) = *(cp2++);
	3504	*cp1 = '\0';
	3505
	3506	return rslt;
	3507
	3508	} /* end of do_tovmsspec() */
	3509	/}}}/
	3510	/* External entry points */
	3511	char Perl_tovmsspec(pTHX_ char path, char *buf) { return do_tovmsspec(path,buf,0); }
	3512	char Perl_tovmsspec_ts(pTHX_ char path, char *buf) { return do_tovmsspec(path,buf,1); }
	3513
	3514	/{{{ char tovmspath[_ts](char path, char buf)*/
	3515	static char mp_do_tovmspath(pTHX_ char path, char *buf, int ts) {
	3516	static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
	3517	int vmslen;
	3518	char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
	3519
	3520	if (path == NULL) return NULL;
	3521	if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
	3522	if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
	3523	if (buf) return buf;
	3524	else if (ts) {
	3525	vmslen = strlen(vmsified);
	3526	New(1317,cp,vmslen+1,char);
	3527	memcpy(cp,vmsified,vmslen);
	3528	cp[vmslen] = '\0';
	3529	return cp;
	3530	}
	3531	else {
	3532	strcpy(__tovmspath_retbuf,vmsified);
	3533	return __tovmspath_retbuf;
	3534	}
	3535
	3536	} /* end of do_tovmspath() */
	3537	/}}}/
	3538	/* External entry points */
	3539	char Perl_tovmspath(pTHX_ char path, char *buf) { return do_tovmspath(path,buf,0); }
	3540	char Perl_tovmspath_ts(pTHX_ char path, char *buf) { return do_tovmspath(path,buf,1); }
	3541
	3542
	3543	/{{{ char tounixpath[_ts](char path, char buf)*/
	3544	static char mp_do_tounixpath(pTHX_ char path, char *buf, int ts) {
	3545	static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
	3546	int unixlen;
	3547	char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
	3548
	3549	if (path == NULL) return NULL;
	3550	if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
	3551	if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
	3552	if (buf) return buf;
	3553	else if (ts) {
	3554	unixlen = strlen(unixified);
	3555	New(1317,cp,unixlen+1,char);
	3556	memcpy(cp,unixified,unixlen);
	3557	cp[unixlen] = '\0';
	3558	return cp;
	3559	}
	3560	else {
	3561	strcpy(__tounixpath_retbuf,unixified);
	3562	return __tounixpath_retbuf;
	3563	}
	3564
	3565	} /* end of do_tounixpath() */
	3566	/}}}/
	3567	/* External entry points */
	3568	char Perl_tounixpath(pTHX_ char path, char *buf) { return do_tounixpath(path,buf,0); }
	3569	char Perl_tounixpath_ts(pTHX_ char path, char *buf) { return do_tounixpath(path,buf,1); }
	3570
	3571	/*
	3572	* @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
	3573	*
	3574	*****************************************************************************
	3575	* *
	3576	* Copyright (C) 1989-1994 by *
	3577	* Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
	3578	* *
	3579	* Permission is hereby granted for the reproduction of this software, *
	3580	* on condition that this copyright notice is included in the reproduction, *
	3581	* and that such reproduction is not for purposes of profit or material *
	3582	* gain. *
	3583	* *
	3584	* 27-Aug-1994 Modified for inclusion in perl5 *
	3585	* by Charles Bailey bailey@newman.upenn.edu *
	3586	*****************************************************************************
	3587	*/
	3588
	3589	/*
	3590	* getredirection() is intended to aid in porting C programs
	3591	* to VMS (Vax-11 C). The native VMS environment does not support
	3592	* '>' and '<' I/O redirection, or command line wild card expansion,
	3593	* or a command line pipe mechanism using the '\|' AND background
	3594	* command execution '&'. All of these capabilities are provided to any
	3595	* C program which calls this procedure as the first thing in the
	3596	* main program.
	3597	* The piping mechanism will probably work with almost any 'filter' type
	3598	* of program. With suitable modification, it may useful for other
	3599	* portability problems as well.
	3600	*
	3601	* Author: Mark Pizzolato mark@infocomm.com
	3602	*/
	3603	struct list_item
	3604	{
	3605	struct list_item *next;
	3606	char *value;
	3607	};
	3608
	3609	static void add_item(struct list_item **head,
	3610	struct list_item **tail,
	3611	char *value,
	3612	int *count);
	3613
	3614	static void mp_expand_wild_cards(pTHX_ char *item,
	3615	struct list_item **head,
	3616	struct list_item **tail,
	3617	int *count);
	3618
	3619	static int background_process(int argc, char **argv);
	3620
	3621	static void pipe_and_fork(pTHX_ char **cmargv);
	3622
	3623	/{{{ void getredirection(int ac, char **av)/
	3624	static void
	3625	mp_getredirection(pTHX_ int ac, char **av)
	3626	/*
	3627	* Process vms redirection arg's. Exit if any error is seen.
	3628	* If getredirection() processes an argument, it is erased
	3629	* from the vector. getredirection() returns a new argc and argv value.
	3630	* In the event that a background command is requested (by a trailing "&"),
	3631	* this routine creates a background subprocess, and simply exits the program.
	3632	*
	3633	* Warning: do not try to simplify the code for vms. The code
	3634	* presupposes that getredirection() is called before any data is
	3635	* read from stdin or written to stdout.
	3636	*
	3637	* Normal usage is as follows:
	3638	*
	3639	* main(argc, argv)
	3640	* int argc;
	3641	* char *argv[];
	3642	* {
	3643	* getredirection(&argc, &argv);
	3644	* }
	3645	*/
	3646	{
	3647	int argc = ac; / Argument Count */
	3648	char *argv = av; /* Argument Vector */
	3649	char ap; / Argument pointer */
	3650	int j; /* argv[] index */
	3651	int item_count = 0; /* Count of Items in List */
	3652	struct list_item list_head = 0; / First Item in List */
	3653	struct list_item list_tail; / Last Item in List */
	3654	char in = NULL; / Input File Name */
	3655	char out = NULL; / Output File Name */
	3656	char outmode = "w"; / Mode to Open Output File */
	3657	char err = NULL; / Error File Name */
	3658	char errmode = "w"; / Mode to Open Error File */
	3659	int cmargc = 0; /* Piped Command Arg Count */
	3660	char *cmargv = NULL;/ Piped Command Arg Vector */
	3661
	3662	/*
	3663	* First handle the case where the last thing on the line ends with
	3664	* a '&'. This indicates the desire for the command to be run in a
	3665	* subprocess, so we satisfy that desire.
	3666	*/
	3667	ap = argv[argc-1];
	3668	if (0 == strcmp("&", ap))
	3669	exit(background_process(--argc, argv));
	3670	if (*ap && '&' == ap[strlen(ap)-1])
	3671	{
	3672	ap[strlen(ap)-1] = '\0';
	3673	exit(background_process(argc, argv));
	3674	}
	3675	/*
	3676	* Now we handle the general redirection cases that involve '>', '>>',
	3677	* '<', and pipes '\|'.
	3678	*/
	3679	for (j = 0; j < argc; ++j)
	3680	{
	3681	if (0 == strcmp("<", argv[j]))
	3682	{
	3683	if (j+1 >= argc)
	3684	{
	3685	fprintf(stderr,"No input file after < on command line");
	3686	exit(LIB$_WRONUMARG);
	3687	}
	3688	in = argv[++j];
	3689	continue;
	3690	}
	3691	if ('<' == *(ap = argv[j]))
	3692	{
	3693	in = 1 + ap;
	3694	continue;
	3695	}
	3696	if (0 == strcmp(">", ap))
	3697	{
	3698	if (j+1 >= argc)
	3699	{
	3700	fprintf(stderr,"No output file after > on command line");
	3701	exit(LIB$_WRONUMARG);
	3702	}
	3703	out = argv[++j];
	3704	continue;
	3705	}
	3706	if ('>' == *ap)
	3707	{
	3708	if ('>' == ap[1])
	3709	{
	3710	outmode = "a";
	3711	if ('\0' == ap[2])
	3712	out = argv[++j];
	3713	else
	3714	out = 2 + ap;
	3715	}
	3716	else
	3717	out = 1 + ap;
	3718	if (j >= argc)
	3719	{
	3720	fprintf(stderr,"No output file after > or >> on command line");
	3721	exit(LIB$_WRONUMARG);
	3722	}
	3723	continue;
	3724	}
	3725	if (('2' == *ap) && ('>' == ap[1]))
	3726	{
	3727	if ('>' == ap[2])
	3728	{
	3729	errmode = "a";
	3730	if ('\0' == ap[3])
	3731	err = argv[++j];
	3732	else
	3733	err = 3 + ap;
	3734	}
	3735	else
	3736	if ('\0' == ap[2])
	3737	err = argv[++j];
	3738	else
	3739	err = 2 + ap;
	3740	if (j >= argc)
	3741	{
	3742	fprintf(stderr,"No output file after 2> or 2>> on command line");
	3743	exit(LIB$_WRONUMARG);
	3744	}
	3745	continue;
	3746	}
	3747	if (0 == strcmp("\|", argv[j]))
	3748	{
	3749	if (j+1 >= argc)
	3750	{
	3751	fprintf(stderr,"No command into which to pipe on command line");
	3752	exit(LIB$_WRONUMARG);
	3753	}
	3754	cmargc = argc-(j+1);
	3755	cmargv = &argv[j+1];
	3756	argc = j;
	3757	continue;
	3758	}
	3759	if ('\|' == *(ap = argv[j]))
	3760	{
	3761	++argv[j];
	3762	cmargc = argc-j;
	3763	cmargv = &argv[j];
	3764	argc = j;
	3765	continue;
	3766	}
	3767	expand_wild_cards(ap, &list_head, &list_tail, &item_count);
	3768	}
	3769	/*
	3770	* Allocate and fill in the new argument vector, Some Unix's terminate
	3771	* the list with an extra null pointer.
	3772	*/
	3773	New(1302, argv, item_count+1, char *);
	3774	*av = argv;
	3775	for (j = 0; j < item_count; ++j, list_head = list_head->next)
	3776	argv[j] = list_head->value;
	3777	*ac = item_count;
	3778	if (cmargv != NULL)
	3779	{
	3780	if (out != NULL)
	3781	{
	3782	fprintf(stderr,"'\|' and '>' may not both be specified on command line");
	3783	exit(LIB$_INVARGORD);
	3784	}
	3785	pipe_and_fork(aTHX_ cmargv);
	3786	}
	3787
	3788	/* Check for input from a pipe (mailbox) */
	3789
	3790	if (in == NULL && 1 == isapipe(0))
	3791	{
	3792	char mbxname[L_tmpnam];
	3793	long int bufsize;
	3794	long int dvi_item = DVI$_DEVBUFSIZ;
	3795	$DESCRIPTOR(mbxnam, "");
	3796	$DESCRIPTOR(mbxdevnam, "");
	3797
	3798	/* Input from a pipe, reopen it in binary mode to disable */
	3799	/* carriage control processing. */
	3800
	3801	fgetname(stdin, mbxname);
	3802	mbxnam.dsc$a_pointer = mbxname;
	3803	mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
	3804	lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
	3805	mbxdevnam.dsc$a_pointer = mbxname;
	3806	mbxdevnam.dsc$w_length = sizeof(mbxname);
	3807	dvi_item = DVI$_DEVNAM;
	3808	lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
	3809	mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
	3810	set_errno(0);
	3811	set_vaxc_errno(1);
	3812	freopen(mbxname, "rb", stdin);
	3813	if (errno != 0)
	3814	{
	3815	fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
	3816	exit(vaxc$errno);
	3817	}
	3818	}
	3819	if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
	3820	{
	3821	fprintf(stderr,"Can't open input file %s as stdin",in);
	3822	exit(vaxc$errno);
	3823	}
	3824	if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
	3825	{
	3826	fprintf(stderr,"Can't open output file %s as stdout",out);
	3827	exit(vaxc$errno);
	3828	}
	3829	if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
	3830
	3831	if (err != NULL) {
	3832	if (strcmp(err,"&1") == 0) {
	3833	dup2(fileno(stdout), fileno(stderr));
	3834	Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
	3835	} else {
	3836	FILE *tmperr;
	3837	if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
	3838	{
	3839	fprintf(stderr,"Can't open error file %s as stderr",err);
	3840	exit(vaxc$errno);
	3841	}
	3842	fclose(tmperr);
	3843	if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
	3844	{
	3845	exit(vaxc$errno);
	3846	}
	3847	Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
	3848	}
	3849	}
	3850	#ifdef ARGPROC_DEBUG
	3851	PerlIO_printf(Perl_debug_log, "Arglist:\n");
	3852	for (j = 0; j < *ac; ++j)
	3853	PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
	3854	#endif
	3855	/* Clear errors we may have hit expanding wildcards, so they don't
	3856	show up in Perl's $! later */
	3857	set_errno(0); set_vaxc_errno(1);
	3858	} /* end of getredirection() */
	3859	/}}}/
	3860
	3861	static void add_item(struct list_item **head,
	3862	struct list_item **tail,
	3863	char *value,
	3864	int *count)
	3865	{
	3866	if (*head == 0)
	3867	{
	3868	New(1303,*head,1,struct list_item);
	3869	tail = head;
	3870	}
	3871	else {
	3872	New(1304,(*tail)->next,1,struct list_item);
	3873	tail = (tail)->next;
	3874	}
	3875	(*tail)->value = value;
	3876	++(*count);
	3877	}
	3878
	3879	static void mp_expand_wild_cards(pTHX_ char *item,
	3880	struct list_item **head,
	3881	struct list_item **tail,
	3882	int *count)
	3883	{
	3884	int expcount = 0;
	3885	unsigned long int context = 0;
	3886	int isunix = 0;
	3887	char *had_version;
	3888	char *had_device;
	3889	int had_directory;
	3890	char devdir,cp;
	3891	char vmsspec[NAM$C_MAXRSS+1];
	3892	$DESCRIPTOR(filespec, "");
	3893	$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
	3894	$DESCRIPTOR(resultspec, "");
	3895	unsigned long int zero = 0, sts;
	3896
	3897	for (cp = item; *cp; cp++) {
	3898	if (cp == '' \|\| cp == '%' \|\| isspace(cp)) break;
	3899	if (cp == '.' && (cp-1) == '.' && *(cp-2) =='.') break;
	3900	}
	3901	if (!cp \|\| isspace(cp))
	3902	{
	3903	add_item(head, tail, item, count);
	3904	return;
	3905	}
	3906	resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
	3907	resultspec.dsc$b_class = DSC$K_CLASS_D;
	3908	resultspec.dsc$a_pointer = NULL;
	3909	if ((isunix = (int) strchr(item,'/')) != (int) NULL)
	3910	filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
	3911	if (!isunix \|\| !filespec.dsc$a_pointer)
	3912	filespec.dsc$a_pointer = item;
	3913	filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
	3914	/*
	3915	* Only return version specs, if the caller specified a version
	3916	*/
	3917	had_version = strchr(item, ';');
	3918	/*
	3919	* Only return device and directory specs, if the caller specifed either.
	3920	*/
	3921	had_device = strchr(item, ':');
	3922	had_directory = (isunix \|\| NULL != strchr(item, '[')) \|\| (NULL != strchr(item, '<'));
	3923
	3924	while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
	3925	&defaultspec, 0, 0, &zero))))
	3926	{
	3927	char *string;
	3928	char *c;
	3929
	3930	New(1305,string,resultspec.dsc$w_length+1,char);
	3931	strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
	3932	string[resultspec.dsc$w_length] = '\0';
	3933	if (NULL == had_version)
	3934	((char )strrchr(string, ';')) = '\0';
	3935	if ((!had_directory) && (had_device == NULL))
	3936	{
	3937	if (NULL == (devdir = strrchr(string, ']')))
	3938	devdir = strrchr(string, '>');
	3939	strcpy(string, devdir + 1);
	3940	}
	3941	/*
	3942	* Be consistent with what the C RTL has already done to the rest of
	3943	* the argv items and lowercase all of these names.
	3944	*/
	3945	for (c = string; *c; ++c)
	3946	if (isupper(*c))
	3947	c = tolower(c);
	3948	if (isunix) trim_unixpath(string,item,1);
	3949	add_item(head, tail, string, count);
	3950	++expcount;
	3951	}
	3952	if (sts != RMS$_NMF)
	3953	{
	3954	set_vaxc_errno(sts);
	3955	switch (sts)
	3956	{
	3957	case RMS$_FNF: case RMS$_DNF:
	3958	set_errno(ENOENT); break;
	3959	case RMS$_DIR:
	3960	set_errno(ENOTDIR); break;
	3961	case RMS$_DEV:
	3962	set_errno(ENODEV); break;
	3963	case RMS$_FNM: case RMS$_SYN:
	3964	set_errno(EINVAL); break;
	3965	case RMS$_PRV:
	3966	set_errno(EACCES); break;
	3967	default:
	3968	_ckvmssts_noperl(sts);
	3969	}
	3970	}
	3971	if (expcount == 0)
	3972	add_item(head, tail, item, count);
	3973	_ckvmssts_noperl(lib$sfree1_dd(&resultspec));
	3974	_ckvmssts_noperl(lib$find_file_end(&context));
	3975	}
	3976
	3977	static int child_st[2];/* Event Flag set when child process completes */
	3978
	3979	static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
	3980
	3981	static unsigned long int exit_handler(int *status)
	3982	{
	3983	short iosb[4];
	3984
	3985	if (0 == child_st[0])
	3986	{
	3987	#ifdef ARGPROC_DEBUG
	3988	PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
	3989	#endif
	3990	fflush(stdout); /* Have to flush pipe for binary data to */
	3991	/* terminate properly -- <tp@mccall.com> */
	3992	sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
	3993	sys$dassgn(child_chan);
	3994	fclose(stdout);
	3995	sys$synch(0, child_st);
	3996	}
	3997	return(1);
	3998	}
	3999
	4000	static void sig_child(int chan)
	4001	{
	4002	#ifdef ARGPROC_DEBUG
	4003	PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
	4004	#endif
	4005	if (child_st[0] == 0)
	4006	child_st[0] = 1;
	4007	}
	4008
	4009	static struct exit_control_block exit_block =
	4010	{
	4011	0,
	4012	exit_handler,
	4013	1,
	4014	&exit_block.exit_status,
	4015	0
	4016	};
	4017
	4018	static void pipe_and_fork(pTHX_ char **cmargv)
	4019	{
	4020	char subcmd[2048];
	4021	$DESCRIPTOR(cmddsc, "");
	4022	static char mbxname[64];
	4023	$DESCRIPTOR(mbxdsc, mbxname);
	4024	int pid, j;
	4025	unsigned long int zero = 0, one = 1;
	4026
	4027	strcpy(subcmd, cmargv[0]);
	4028	for (j = 1; NULL != cmargv[j]; ++j)
	4029	{
	4030	strcat(subcmd, " \"");
	4031	strcat(subcmd, cmargv[j]);
	4032	strcat(subcmd, "\"");
	4033	}
	4034	cmddsc.dsc$a_pointer = subcmd;
	4035	cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
	4036
	4037	create_mbx(aTHX_ &child_chan,&mbxdsc);
	4038	#ifdef ARGPROC_DEBUG
	4039	PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
	4040	PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
	4041	#endif
	4042	_ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
	4043	0, &pid, child_st, &zero, sig_child,
	4044	&child_chan));
	4045	#ifdef ARGPROC_DEBUG
	4046	PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
	4047	#endif
	4048	sys$dclexh(&exit_block);
	4049	if (NULL == freopen(mbxname, "wb", stdout))
	4050	{
	4051	PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
	4052	}
	4053	}
	4054
	4055	static int background_process(int argc, char **argv)
	4056	{
	4057	char command[2048] = "$";
	4058	$DESCRIPTOR(value, "");
	4059	static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
	4060	static $DESCRIPTOR(null, "NLA0:");
	4061	static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
	4062	char pidstring[80];
	4063	$DESCRIPTOR(pidstr, "");
	4064	int pid;
	4065	unsigned long int flags = 17, one = 1, retsts;
	4066
	4067	strcat(command, argv[0]);
	4068	while (--argc)
	4069	{
	4070	strcat(command, " \"");
	4071	strcat(command, *(++argv));
	4072	strcat(command, "\"");
	4073	}
	4074	value.dsc$a_pointer = command;
	4075	value.dsc$w_length = strlen(value.dsc$a_pointer);
	4076	_ckvmssts_noperl(lib$set_symbol(&cmd, &value));
	4077	retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
	4078	if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
	4079	_ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
	4080	}
	4081	else {
	4082	_ckvmssts_noperl(retsts);
	4083	}
	4084	#ifdef ARGPROC_DEBUG
	4085	PerlIO_printf(Perl_debug_log, "%s\n", command);
	4086	#endif
	4087	sprintf(pidstring, "%08X", pid);
	4088	PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
	4089	pidstr.dsc$a_pointer = pidstring;
	4090	pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
	4091	lib$set_symbol(&pidsymbol, &pidstr);
	4092	return(SS$_NORMAL);
	4093	}
	4094	/}}}/
	4095	/*** End of code taken from Mark Pizzolato's argproc.c package ***/
	4096
	4097
	4098	/* OS-specific initialization at image activation (not thread startup) */
	4099	/* Older VAXC header files lack these constants */
	4100	#ifndef JPI$_RIGHTS_SIZE
	4101	# define JPI$_RIGHTS_SIZE 817
	4102	#endif
	4103	#ifndef KGB$M_SUBSYSTEM
	4104	# define KGB$M_SUBSYSTEM 0x8
	4105	#endif
	4106
	4107	/{{{void vms_image_init(int , char **)/
	4108	void
	4109	vms_image_init(int argcp, char **argvp)
	4110	{
	4111	char eqv[LNM$C_NAMLENGTH+1] = "";
	4112	unsigned int len, tabct = 8, tabidx = 0;
	4113	unsigned long int *mask, iosb[2], i, rlst[128], rsz;
	4114	unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
	4115	unsigned short int dummy, rlen;
	4116	struct dsc$descriptor_s **tabvec;
	4117	#if defined(PERL_IMPLICIT_CONTEXT)
	4118	pTHX = NULL;
	4119	#endif
	4120	struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
	4121	{sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
	4122	{ sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
	4123	{ 0, 0, 0, 0} };
	4124
	4125	_ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
	4126	_ckvmssts_noperl(iosb[0]);
	4127	for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
	4128	if (iprv[i]) { /* Running image installed with privs? */
	4129	_ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
	4130	will_taint = TRUE;
	4131	break;
	4132	}
	4133	}
	4134	/* Rights identifiers might trigger tainting as well. */
	4135	if (!will_taint && (rlen \|\| rsz)) {
	4136	while (rlen < rsz) {
	4137	/* We didn't get all the identifiers on the first pass. Allocate a
	4138	* buffer much larger than $GETJPI wants (rsz is size in bytes that
	4139	* were needed to hold all identifiers at time of last call; we'll
	4140	* allocate that many unsigned long ints), and go back and get 'em.
	4141	* If it gave us less than it wanted to despite ample buffer space,
	4142	* something's broken. Is your system missing a system identifier?
	4143	*/
	4144	if (rsz <= jpilist[1].buflen) {
	4145	/* Perl_croak accvios when used this early in startup. */
	4146	fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
	4147	rsz, (unsigned long) jpilist[1].buflen,
	4148	"Check your rights database for corruption.\n");
	4149	exit(SS$_ABORT);
	4150	}
	4151	if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
	4152	jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
	4153	jpilist[1].buflen = rsz * sizeof(unsigned long int);
	4154	_ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
	4155	_ckvmssts_noperl(iosb[0]);
	4156	}
	4157	mask = jpilist[1].bufadr;
	4158	/* Check attribute flags for each identifier (2nd longword); protected
	4159	* subsystem identifiers trigger tainting.
	4160	*/
	4161	for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
	4162	if (mask[i] & KGB$M_SUBSYSTEM) {
	4163	will_taint = TRUE;
	4164	break;
	4165	}
	4166	}
	4167	if (mask != rlst) Safefree(mask);
	4168	}
	4169	/* We need to use this hack to tell Perl it should run with tainting,
	4170	* since its tainting flag may be part of the PL_curinterp struct, which
	4171	* hasn't been allocated when vms_image_init() is called.
	4172	*/
	4173	if (will_taint) {
	4174	char ***newap;
	4175	New(1320,newap,argcp+2,char *);
	4176	newap[0] = argvp[0];
	4177	*newap[1] = "-T";
	4178	Copy(argvp[1],newap[2],argcp-1,char *);
	4179	/* We orphan the old argv, since we don't know where it's come from,
	4180	* so we don't know how to free it.
	4181	*/
	4182	*argcp++; argvp = newap;
	4183	}
	4184	else { /* Did user explicitly request tainting? */
	4185	int i;
	4186	char cp, av = argvp;
	4187	for (i = 1; i < *argcp; i++) {
	4188	if (*av[i] != '-') break;
	4189	for (cp = av[i]+1; *cp; cp++) {
	4190	if (*cp == 'T') { will_taint = 1; break; }
	4191	else if ( (cp == 'd' \|\| cp == 'V') && *(cp+1) == ':' \|\|
	4192	strchr("DFIiMmx",*cp)) break;
	4193	}
	4194	if (will_taint) break;
	4195	}
	4196	}
	4197
	4198	for (tabidx = 0;
	4199	len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
	4200	tabidx++) {
	4201	if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
	4202	else if (tabidx >= tabct) {
	4203	tabct += 8;
	4204	Renew(tabvec,tabct,struct dsc$descriptor_s *);
	4205	}
	4206	New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
	4207	tabvec[tabidx]->dsc$w_length = 0;
	4208	tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
	4209	tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
	4210	tabvec[tabidx]->dsc$a_pointer = NULL;
	4211	_ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
	4212	}
	4213	if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
	4214
	4215	getredirection(argcp,argvp);
	4216	#if defined(USE_5005THREADS) && ( defined(__DECC) \|\| defined(__DECCXX) )
	4217	{
	4218	# include <reentrancy.h>
	4219	(void) decc$set_reentrancy(C$C_MULTITHREAD);
	4220	}
	4221	#endif
	4222	return;
	4223	}
	4224	/}}}/
	4225
	4226
	4227	/* trim_unixpath()
	4228	* Trim Unix-style prefix off filespec, so it looks like what a shell
	4229	* glob expansion would return (i.e. from specified prefix on, not
	4230	* full path). Note that returned filespec is Unix-style, regardless
	4231	* of whether input filespec was VMS-style or Unix-style.
	4232	*
	4233	* fspec is filespec to be trimmed, and wildspec is wildcard spec used to
	4234	* determine prefix (both may be in VMS or Unix syntax). opts is a bit
	4235	* vector of options; at present, only bit 0 is used, and if set tells
	4236	* trim unixpath to try the current default directory as a prefix when
	4237	* presented with a possibly ambiguous ... wildcard.
	4238	*
	4239	* Returns !=0 on success, with trimmed filespec replacing contents of
	4240	* fspec, and 0 on failure, with contents of fpsec unchanged.
	4241	*/
	4242	/{{{int trim_unixpath(char fspec, char wildspec, int opts)/
	4243	int
	4244	Perl_trim_unixpath(pTHX_ char fspec, char wildspec, int opts)
	4245	{
	4246	char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
	4247	template, base, end, cp1, *cp2;
	4248	register int tmplen, reslen = 0, dirs = 0;
	4249
	4250	if (!wildspec \|\| !fspec) return 0;
	4251	if (strpbrk(wildspec,"]>:") != NULL) {
	4252	if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
	4253	else template = unixwild;
	4254	}
	4255	else template = wildspec;
	4256	if (strpbrk(fspec,"]>:") != NULL) {
	4257	if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
	4258	else base = unixified;
	4259	/* reslen != 0 ==> we had to unixify resultant filespec, so we must
	4260	* check to see that final result fits into (isn't longer than) fspec */
	4261	reslen = strlen(fspec);
	4262	}
	4263	else base = fspec;
	4264
	4265	/* No prefix or absolute path on wildcard, so nothing to remove */
	4266	if (!template \|\| template == '/') {
	4267	if (base == fspec) return 1;
	4268	tmplen = strlen(unixified);
	4269	if (tmplen > reslen) return 0; /* not enough space */
	4270	/* Copy unixified resultant, including trailing NUL */
	4271	memmove(fspec,unixified,tmplen+1);
	4272	return 1;
	4273	}
	4274
	4275	for (end = base; end; end++) ; / Find end of resultant filespec */
	4276	if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
	4277	for (cp1 = template; cp1; cp1++) if (cp1 == '/') dirs++;
	4278	for (cp1 = end ;cp1 >= base; cp1--)
	4279	if ((cp1 == '/') && !dirs--) / postdec so we get front of rel path */
	4280	{ cp1++; break; }
	4281	if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
	4282	return 1;
	4283	}
	4284	else {
	4285	char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
	4286	char front, nextell, lcend, lcfront, *ellipsis = cp1;
	4287	int ells = 1, totells, segdirs, match;
	4288	struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
	4289	resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
	4290
	4291	while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
	4292	totells = ells;
	4293	for (cp1 = ellipsis+4; cp1; cp1++) if (cp1 == '/') dirs++;
	4294	if (ellipsis == template && opts & 1) {
	4295	/* Template begins with an ellipsis. Since we can't tell how many
	4296	* directory names at the front of the resultant to keep for an
	4297	* arbitrary starting point, we arbitrarily choose the current
	4298	* default directory as a starting point. If it's there as a prefix,
	4299	* clip it off. If not, fall through and act as if the leading
	4300	* ellipsis weren't there (i.e. return shortest possible path that
	4301	* could match template).
	4302	*/
	4303	if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
	4304	for (cp1 = tpl, cp2 = base; cp1 && cp2; cp1++,cp2++)
	4305	if (_tolower(cp1) != _tolower(cp2)) break;
	4306	segdirs = dirs - totells; /* Min # of dirs we must have left */
	4307	for (front = cp2+1; front; front++) if (front == '/') segdirs--;
	4308	if (cp1 == '\0' && cp2 == '/' && segdirs < 1) {
	4309	memcpy(fspec,cp2+1,end - cp2);
	4310	return 1;
	4311	}
	4312	}
	4313	/* First off, back up over constant elements at end of path */
	4314	if (dirs) {
	4315	for (front = end ; front >= base; front--)
	4316	if (*front == '/' && !dirs--) { front++; break; }
	4317	}
	4318	for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
	4319	cp1++,cp2++) cp2 = _tolower(cp1); /* Make lc copy for match */
	4320	if (cp1 != '\0') return 0; /* Path too long. */
	4321	lcend = cp2;
	4322	cp2 = '\0'; / Pick up with memcpy later */
	4323	lcfront = lcres + (front - base);
	4324	/* Now skip over each ellipsis and try to match the path in front of it. */
	4325	while (ells--) {
	4326	for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
	4327	if ((cp1) == '.' && (cp1+1) == '.' &&
	4328	(cp1+2) == '.' && (cp1+3) == '/' ) break;
	4329	if (cp1 < template) break; /* template started with an ellipsis */
	4330	if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
	4331	ellipsis = cp1; continue;
	4332	}
	4333	wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
	4334	nextell = cp1;
	4335	for (segdirs = 0, cp2 = tpl;
	4336	cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
	4337	cp1++, cp2++) {
	4338	if (cp1 == '?') cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
	4339	else cp2 = _tolower(cp1); /* else lowercase for match */
	4340	if (*cp2 == '/') segdirs++;
	4341	}
	4342	if (cp1 != ellipsis - 1) return 0; /* Path too long */
	4343	/* Back up at least as many dirs as in template before matching */
	4344	for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
	4345	if (*cp1 == '/' && !segdirs--) { cp1++; break; }
	4346	for (match = 0; cp1 > lcres;) {
	4347	resdsc.dsc$a_pointer = cp1;
	4348	if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
	4349	match++;
	4350	if (match == 1) lcfront = cp1;
	4351	}
	4352	for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
	4353	}
	4354	if (!match) return 0; /* Can't find prefix ??? */
	4355	if (match > 1 && opts & 1) {
	4356	/* This ... wildcard could cover more than one set of dirs (i.e.
	4357	* a set of similar dir names is repeated). If the template
	4358	* contains more than 1 ..., upstream elements could resolve the
	4359	* ambiguity, but it's not worth a full backtracking setup here.
	4360	* As a quick heuristic, clip off the current default directory
	4361	* if it's present to find the trimmed spec, else use the
	4362	* shortest string that this ... could cover.
	4363	*/
	4364	char def[NAM$C_MAXRSS+1], *st;
	4365
	4366	if (getcwd(def, sizeof def,0) == NULL) return 0;
	4367	for (cp1 = def, cp2 = base; cp1 && cp2; cp1++,cp2++)
	4368	if (_tolower(cp1) != _tolower(cp2)) break;
	4369	segdirs = dirs - totells; /* Min # of dirs we must have left */
	4370	for (st = cp2+1; st; st++) if (st == '/') segdirs--;
	4371	if (cp1 == '\0' && cp2 == '/') {
	4372	memcpy(fspec,cp2+1,end - cp2);
	4373	return 1;
	4374	}
	4375	/* Nope -- stick with lcfront from above and keep going. */
	4376	}
	4377	}
	4378	memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
	4379	return 1;
	4380	ellipsis = nextell;
	4381	}
	4382
	4383	} /* end of trim_unixpath() */
	4384	/}}}/
	4385
	4386
	4387	/*
	4388	* VMS readdir() routines.
	4389	* Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
	4390	*
	4391	* 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
	4392	* Minor modifications to original routines.
	4393	*/
	4394
	4395	/* Number of elements in vms_versions array */
	4396	#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
	4397
	4398	/*
	4399	* Open a directory, return a handle for later use.
	4400	*/
	4401	/{{{ DIR opendir(charname) /
	4402	DIR *
	4403	Perl_opendir(pTHX_ char *name)
	4404	{
	4405	DIR *dd;
	4406	char dir[NAM$C_MAXRSS+1];
	4407	Stat_t sb;
	4408
	4409	if (do_tovmspath(name,dir,0) == NULL) {
	4410	return NULL;
	4411	}
	4412	if (flex_stat(dir,&sb) == -1) return NULL;
	4413	if (!S_ISDIR(sb.st_mode)) {
	4414	set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
	4415	return NULL;
	4416	}
	4417	if (!cando_by_name(S_IRUSR,0,dir)) {
	4418	set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
	4419	return NULL;
	4420	}
	4421	/* Get memory for the handle, and the pattern. */
	4422	New(1306,dd,1,DIR);
	4423	New(1307,dd->pattern,strlen(dir)+sizeof "." + 1,char);
	4424
	4425	/* Fill in the fields; mainly playing with the descriptor. */
	4426	(void)sprintf(dd->pattern, "%s.",dir);
	4427	dd->context = 0;
	4428	dd->count = 0;
	4429	dd->vms_wantversions = 0;
	4430	dd->pat.dsc$a_pointer = dd->pattern;
	4431	dd->pat.dsc$w_length = strlen(dd->pattern);
	4432	dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
	4433	dd->pat.dsc$b_class = DSC$K_CLASS_S;
	4434
	4435	return dd;
	4436	} /* end of opendir() */
	4437	/}}}/
	4438
	4439	/*
	4440	* Set the flag to indicate we want versions or not.
	4441	*/
	4442	/{{{ void vmsreaddirversions(DIR dd, int flag)*/
	4443	void
	4444	vmsreaddirversions(DIR *dd, int flag)
	4445	{
	4446	dd->vms_wantversions = flag;
	4447	}
	4448	/}}}/
	4449
	4450	/*
	4451	* Free up an opened directory.
	4452	*/
	4453	/{{{ void closedir(DIR dd)*/
	4454	void
	4455	closedir(DIR *dd)
	4456	{
	4457	(void)lib$find_file_end(&dd->context);
	4458	Safefree(dd->pattern);
	4459	Safefree((char *)dd);
	4460	}
	4461	/}}}/
	4462
	4463	/*
	4464	* Collect all the version numbers for the current file.
	4465	*/
	4466	static void
	4467	collectversions(pTHX_ DIR *dd)
	4468	{
	4469	struct dsc$descriptor_s pat;
	4470	struct dsc$descriptor_s res;
	4471	struct dirent *e;
	4472	char p, text, buff[sizeof dd->entry.d_name];
	4473	int i;
	4474	unsigned long context, tmpsts;
	4475
	4476	/* Convenient shorthand. */
	4477	e = &dd->entry;
	4478
	4479	/* Add the version wildcard, ignoring the "." put on before */
	4480	i = strlen(dd->pattern);
	4481	New(1308,text,i + e->d_namlen + 3,char);
	4482	(void)strcpy(text, dd->pattern);
	4483	(void)sprintf(&text[i - 3], "%s;*", e->d_name);
	4484
	4485	/* Set up the pattern descriptor. */
	4486	pat.dsc$a_pointer = text;
	4487	pat.dsc$w_length = i + e->d_namlen - 1;
	4488	pat.dsc$b_dtype = DSC$K_DTYPE_T;
	4489	pat.dsc$b_class = DSC$K_CLASS_S;
	4490
	4491	/* Set up result descriptor. */
	4492	res.dsc$a_pointer = buff;
	4493	res.dsc$w_length = sizeof buff - 2;
	4494	res.dsc$b_dtype = DSC$K_DTYPE_T;
	4495	res.dsc$b_class = DSC$K_CLASS_S;
	4496
	4497	/* Read files, collecting versions. */
	4498	for (context = 0, e->vms_verscount = 0;
	4499	e->vms_verscount < VERSIZE(e);
	4500	e->vms_verscount++) {
	4501	tmpsts = lib$find_file(&pat, &res, &context);
	4502	if (tmpsts == RMS$_NMF \|\| context == 0) break;
	4503	_ckvmssts(tmpsts);
	4504	buff[sizeof buff - 1] = '\0';
	4505	if ((p = strchr(buff, ';')))
	4506	e->vms_versions[e->vms_verscount] = atoi(p + 1);
	4507	else
	4508	e->vms_versions[e->vms_verscount] = -1;
	4509	}
	4510
	4511	_ckvmssts(lib$find_file_end(&context));
	4512	Safefree(text);
	4513
	4514	} /* end of collectversions() */
	4515
	4516	/*
	4517	* Read the next entry from the directory.
	4518	*/
	4519	/{{{ struct dirent readdir(DIR dd)/
	4520	struct dirent *
	4521	Perl_readdir(pTHX_ DIR *dd)
	4522	{
	4523	struct dsc$descriptor_s res;
	4524	char *p, buff[sizeof dd->entry.d_name];
	4525	unsigned long int tmpsts;
	4526
	4527	/* Set up result descriptor, and get next file. */
	4528	res.dsc$a_pointer = buff;
	4529	res.dsc$w_length = sizeof buff - 2;
	4530	res.dsc$b_dtype = DSC$K_DTYPE_T;
	4531	res.dsc$b_class = DSC$K_CLASS_S;
	4532	tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
	4533	if ( tmpsts == RMS$_NMF \|\| dd->context == 0) return NULL; /* None left. */
	4534	if (!(tmpsts & 1)) {
	4535	set_vaxc_errno(tmpsts);
	4536	switch (tmpsts) {
	4537	case RMS$_PRV:
	4538	set_errno(EACCES); break;
	4539	case RMS$_DEV:
	4540	set_errno(ENODEV); break;
	4541	case RMS$_DIR:
	4542	set_errno(ENOTDIR); break;
	4543	case RMS$_FNF: case RMS$_DNF:
	4544	set_errno(ENOENT); break;
	4545	default:
	4546	set_errno(EVMSERR);
	4547	}
	4548	return NULL;
	4549	}
	4550	dd->count++;
	4551	/* Force the buffer to end with a NUL, and downcase name to match C convention. */
	4552	buff[sizeof buff - 1] = '\0';
	4553	for (p = buff; p; p++) p = _tolower(*p);
	4554	while (--p >= buff) if (!isspace(p)) break; / Do we really need this? */
	4555	*p = '\0';
	4556
	4557	/* Skip any directory component and just copy the name. */
	4558	if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
	4559	else (void)strcpy(dd->entry.d_name, buff);
	4560
	4561	/* Clobber the version. */
	4562	if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
	4563
	4564	dd->entry.d_namlen = strlen(dd->entry.d_name);
	4565	dd->entry.vms_verscount = 0;
	4566	if (dd->vms_wantversions) collectversions(aTHX_ dd);
	4567	return &dd->entry;
	4568
	4569	} /* end of readdir() */
	4570	/}}}/
	4571
	4572	/*
	4573	* Return something that can be used in a seekdir later.
	4574	*/
	4575	/{{{ long telldir(DIR dd)*/
	4576	long
	4577	telldir(DIR *dd)
	4578	{
	4579	return dd->count;
	4580	}
	4581	/}}}/
	4582
	4583	/*
	4584	* Return to a spot where we used to be. Brute force.
	4585	*/
	4586	/{{{ void seekdir(DIR dd,long count)*/
	4587	void
	4588	Perl_seekdir(pTHX_ DIR *dd, long count)
	4589	{
	4590	int vms_wantversions;
	4591
	4592	/* If we haven't done anything yet... */
	4593	if (dd->count == 0)
	4594	return;
	4595
	4596	/* Remember some state, and clear it. */
	4597	vms_wantversions = dd->vms_wantversions;
	4598	dd->vms_wantversions = 0;
	4599	_ckvmssts(lib$find_file_end(&dd->context));
	4600	dd->context = 0;
	4601
	4602	/* The increment is in readdir(). */
	4603	for (dd->count = 0; dd->count < count; )
	4604	(void)readdir(dd);
	4605
	4606	dd->vms_wantversions = vms_wantversions;
	4607
	4608	} /* end of seekdir() */
	4609	/}}}/
	4610
	4611	/* VMS subprocess management
	4612	*
	4613	* my_vfork() - just a vfork(), after setting a flag to record that
	4614	* the current script is trying a Unix-style fork/exec.
	4615	*
	4616	* vms_do_aexec() and vms_do_exec() are called in response to the
	4617	* perl 'exec' function. If this follows a vfork call, then they
	4618	* call out the the regular perl routines in doio.c which do an
	4619	* execvp (for those who really want to try this under VMS).
	4620	* Otherwise, they do exactly what the perl docs say exec should
	4621	* do - terminate the current script and invoke a new command
	4622	* (See below for notes on command syntax.)
	4623	*
	4624	* do_aspawn() and do_spawn() implement the VMS side of the perl
	4625	* 'system' function.
	4626	*
	4627	* Note on command arguments to perl 'exec' and 'system': When handled
	4628	* in 'VMSish fashion' (i.e. not after a call to vfork) The args
	4629	* are concatenated to form a DCL command string. If the first arg
	4630	* begins with '$' (i.e. the perl script had "\$ Type" or some such),
	4631	* the the command string is handed off to DCL directly. Otherwise,
	4632	* the first token of the command is taken as the filespec of an image
	4633	* to run. The filespec is expanded using a default type of '.EXE' and
	4634	* the process defaults for device, directory, etc., and if found, the resultant
	4635	* filespec is invoked using the DCL verb 'MCR', and passed the rest of
	4636	* the command string as parameters. This is perhaps a bit complicated,
	4637	* but I hope it will form a happy medium between what VMS folks expect
	4638	* from lib$spawn and what Unix folks expect from exec.
	4639	*/
	4640
	4641	static int vfork_called;
	4642
	4643	/{{{int my_vfork()/
	4644	int
	4645	my_vfork()
	4646	{
	4647	vfork_called++;
	4648	return vfork();
	4649	}
	4650	/}}}/
	4651
	4652
	4653	static void
	4654	vms_execfree(pTHX) {
	4655	if (PL_Cmd) {
	4656	if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
	4657	PL_Cmd = Nullch;
	4658	}
	4659	if (VMScmd.dsc$a_pointer) {
	4660	Safefree(VMScmd.dsc$a_pointer);
	4661	VMScmd.dsc$w_length = 0;
	4662	VMScmd.dsc$a_pointer = Nullch;
	4663	}
	4664	}
	4665
	4666	static char *
	4667	setup_argstr(pTHX_ SV really, SV mark, SV *sp)
	4668	{
	4669	char junk, tmps = Nullch;
	4670	register size_t cmdlen = 0;
	4671	size_t rlen;
	4672	register SV **idx;
	4673	STRLEN n_a;
	4674
	4675	idx = mark;
	4676	if (really) {
	4677	tmps = SvPV(really,rlen);
	4678	if (*tmps) {
	4679	cmdlen += rlen + 1;
	4680	idx++;
	4681	}
	4682	}
	4683
	4684	for (idx++; idx <= sp; idx++) {
	4685	if (*idx) {
	4686	junk = SvPVx(*idx,rlen);
	4687	cmdlen += rlen ? rlen + 1 : 0;
	4688	}
	4689	}
	4690	New(401,PL_Cmd,cmdlen+1,char);
	4691
	4692	if (tmps && *tmps) {
	4693	strcpy(PL_Cmd,tmps);
	4694	mark++;
	4695	}
	4696	else *PL_Cmd = '\0';
	4697	while (++mark <= sp) {
	4698	if (*mark) {
	4699	char s = SvPVx(mark,n_a);
	4700	if (!*s) continue;
	4701	if (*PL_Cmd) strcat(PL_Cmd," ");
	4702	strcat(PL_Cmd,s);
	4703	}
	4704	}
	4705	return PL_Cmd;
	4706
	4707	} /* end of setup_argstr() */
	4708
	4709	#define MAX_DCL_LINE_LENGTH 255
	4710
	4711	static unsigned long int
	4712	setup_cmddsc(pTHX_ char *cmd, int check_img)
	4713	{
	4714	char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
	4715	$DESCRIPTOR(defdsc,".EXE");
	4716	$DESCRIPTOR(defdsc2,".");
	4717	$DESCRIPTOR(resdsc,resspec);
	4718	struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
	4719	unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
	4720	register char s, rest, cp, wordbreak;
	4721	register int isdcl;
	4722
	4723	if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
	4724	return CLI$_BUFOVF; /* continuation lines currently unsupported */
	4725	s = cmd;
	4726	while (s && isspace(s)) s++;
	4727
	4728	if (s == '@' \|\| s == '$') {
	4729	vmsspec[0] = *s; rest = s + 1;
	4730	for (cp = &vmsspec[1]; rest && isspace(rest); rest++,cp++) cp = rest;
	4731	}
	4732	else { cp = vmsspec; rest = s; }
	4733	if (rest == '.' \|\| rest == '/') {
	4734	char *cp2;
	4735	for (cp2 = resspec;
	4736	rest && !isspace(rest) && cp2 - resspec < sizeof resspec;
	4737	rest++, cp2++) cp2 = rest;
	4738	*cp2 = '\0';
	4739	if (do_tovmsspec(resspec,cp,0)) {
	4740	s = vmsspec;
	4741	if (*rest) {
	4742	for (cp2 = vmsspec + strlen(vmsspec);
	4743	*rest && cp2 - vmsspec < sizeof vmsspec;
	4744	rest++, cp2++) cp2 = rest;
	4745	*cp2 = '\0';
	4746	}
	4747	}
	4748	}
	4749	/* Intuit whether verb (first word of cmd) is a DCL command:
	4750	* - if first nonspace char is '@', it's a DCL indirection
	4751	* otherwise
	4752	* - if verb contains a filespec separator, it's not a DCL command
	4753	* - if it doesn't, caller tells us whether to default to a DCL
	4754	* command, or to a local image unless told it's DCL (by leading '$')
	4755	*/
	4756	if (*s == '@') isdcl = 1;
	4757	else {
	4758	register char *filespec = strpbrk(s,":<[.;");
	4759	rest = wordbreak = strpbrk(s," \"\t/");
	4760	if (!wordbreak) wordbreak = s + strlen(s);
	4761	if (*s == '$') check_img = 0;
	4762	if (filespec && (filespec < wordbreak)) isdcl = 0;
	4763	else isdcl = !check_img;
	4764	}
	4765
	4766	if (!isdcl) {
	4767	imgdsc.dsc$a_pointer = s;
	4768	imgdsc.dsc$w_length = wordbreak - s;
	4769	retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
	4770	if (!(retsts&1)) {
	4771	_ckvmssts(lib$find_file_end(&cxt));
	4772	retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
	4773	if (!(retsts & 1) && *s == '$') {
	4774	_ckvmssts(lib$find_file_end(&cxt));
	4775	imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
	4776	retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
	4777	if (!(retsts&1)) {
	4778	_ckvmssts(lib$find_file_end(&cxt));
	4779	retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
	4780	}
	4781	}
	4782	}
	4783	_ckvmssts(lib$find_file_end(&cxt));
	4784
	4785	if (retsts & 1) {
	4786	FILE *fp;
	4787	s = resspec;
	4788	while (s && !isspace(s)) s++;
	4789	*s = '\0';
	4790
	4791	/* check that it's really not DCL with no file extension */
	4792	fp = fopen(resspec,"r","ctx=bin,shr=get");
	4793	if (fp) {
	4794	char b[4] = {0,0,0,0};
	4795	read(fileno(fp),b,4);
	4796	isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
	4797	fclose(fp);
	4798	}
	4799	if (check_img && isdcl) return RMS$_FNF;
	4800
	4801	if (cando_by_name(S_IXUSR,0,resspec)) {
	4802	New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
	4803	if (!isdcl) {
	4804	strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
	4805	} else {
	4806	strcpy(VMScmd.dsc$a_pointer,"@");
	4807	}
	4808	strcat(VMScmd.dsc$a_pointer,resspec);
	4809	if (rest) strcat(VMScmd.dsc$a_pointer,rest);
	4810	VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
	4811	return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
	4812	}
	4813	else retsts = RMS$_PRV;
	4814	}
	4815	}
	4816	/* It's either a DCL command or we couldn't find a suitable image */
	4817	VMScmd.dsc$w_length = strlen(cmd);
	4818	if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
	4819	else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
	4820	if (!(retsts & 1)) {
	4821	/* just hand off status values likely to be due to user error */
	4822	if (retsts == RMS$_FNF \|\| retsts == RMS$_DNF \|\| retsts == RMS$_PRV \|\|
	4823	retsts == RMS$_DEV \|\| retsts == RMS$_DIR \|\| retsts == RMS$_SYN \|\|
	4824	(retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
	4825	else { _ckvmssts(retsts); }
	4826	}
	4827
	4828	return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
	4829
	4830	} /* end of setup_cmddsc() */
	4831
	4832
	4833	/* {{{ bool vms_do_aexec(SV really,SV mark,SV sp) /
	4834	bool
	4835	Perl_vms_do_aexec(pTHX_ SV really,SV mark,SV *sp)
	4836	{
	4837	if (sp > mark) {
	4838	if (vfork_called) { /* this follows a vfork - act Unixish */
	4839	vfork_called--;
	4840	if (vfork_called < 0) {
	4841	Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
	4842	vfork_called = 0;
	4843	}
	4844	else return do_aexec(really,mark,sp);
	4845	}
	4846	/* no vfork - act VMSish */
	4847	return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
	4848
	4849	}
	4850
	4851	return FALSE;
	4852	} /* end of vms_do_aexec() */
	4853	/}}}/
	4854
	4855	/* {{{bool vms_do_exec(char cmd) /
	4856	bool
	4857	Perl_vms_do_exec(pTHX_ char *cmd)
	4858	{
	4859
	4860	if (vfork_called) { /* this follows a vfork - act Unixish */
	4861	vfork_called--;
	4862	if (vfork_called < 0) {
	4863	Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
	4864	vfork_called = 0;
	4865	}
	4866	else return do_exec(cmd);
	4867	}
	4868
	4869	{ /* no vfork - act VMSish */
	4870	unsigned long int retsts;
	4871
	4872	TAINT_ENV();
	4873	TAINT_PROPER("exec");
	4874	if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1)
	4875	retsts = lib$do_command(&VMScmd);
	4876
	4877	switch (retsts) {
	4878	case RMS$_FNF: case RMS$_DNF:
	4879	set_errno(ENOENT); break;
	4880	case RMS$_DIR:
	4881	set_errno(ENOTDIR); break;
	4882	case RMS$_DEV:
	4883	set_errno(ENODEV); break;
	4884	case RMS$_PRV:
	4885	set_errno(EACCES); break;
	4886	case RMS$_SYN:
	4887	set_errno(EINVAL); break;
	4888	case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
	4889	set_errno(E2BIG); break;
	4890	case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
	4891	_ckvmssts(retsts); /* fall through */
	4892	default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
	4893	set_errno(EVMSERR);
	4894	}
	4895	set_vaxc_errno(retsts);
	4896	if (ckWARN(WARN_EXEC)) {
	4897	Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
	4898	VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
	4899	}
	4900	vms_execfree(aTHX);
	4901	}
	4902
	4903	return FALSE;
	4904
	4905	} /* end of vms_do_exec() */
	4906	/}}}/
	4907
	4908	unsigned long int Perl_do_spawn(pTHX_ char *);
	4909
	4910	/* {{{ unsigned long int do_aspawn(void really,void mark,void sp) /
	4911	unsigned long int
	4912	Perl_do_aspawn(pTHX_ void really,void mark,void *sp)
	4913	{
	4914	if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV )really,(SV )mark,(SV *)sp));
	4915
	4916	return SS$_ABORT;
	4917	} /* end of do_aspawn() */
	4918	/}}}/
	4919
	4920	/* {{{unsigned long int do_spawn(char cmd) /
	4921	unsigned long int
	4922	Perl_do_spawn(pTHX_ char *cmd)
	4923	{
	4924	unsigned long int sts, substs, hadcmd = 1;
	4925
	4926	TAINT_ENV();
	4927	TAINT_PROPER("spawn");
	4928	if (!cmd \|\| !*cmd) {
	4929	hadcmd = 0;
	4930	sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
	4931	}
	4932	else {
	4933	sts = setup_cmddsc(aTHX_ cmd,0);
	4934	if (sts & 1) {
	4935	sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
	4936	} else {
	4937	substs = sts; /* didn't spawn, use command setup failure for return */
	4938	}
	4939	}
	4940
	4941	if (!(sts & 1)) {
	4942	switch (sts) {
	4943	case RMS$_FNF: case RMS$_DNF:
	4944	set_errno(ENOENT); break;
	4945	case RMS$_DIR:
	4946	set_errno(ENOTDIR); break;
	4947	case RMS$_DEV:
	4948	set_errno(ENODEV); break;
	4949	case RMS$_PRV:
	4950	set_errno(EACCES); break;
	4951	case RMS$_SYN:
	4952	set_errno(EINVAL); break;
	4953	case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
	4954	set_errno(E2BIG); break;
	4955	case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
	4956	_ckvmssts(sts); /* fall through */
	4957	default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
	4958	set_errno(EVMSERR);
	4959	}
	4960	set_vaxc_errno(sts);
	4961	if (ckWARN(WARN_EXEC)) {
	4962	Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
	4963	hadcmd ? VMScmd.dsc$w_length : 0,
	4964	hadcmd ? VMScmd.dsc$a_pointer : "",
	4965	Strerror(errno));
	4966	}
	4967	}
	4968	vms_execfree(aTHX);
	4969	return substs;
	4970
	4971	} /* end of do_spawn() */
	4972	/}}}/
	4973
	4974
	4975	static unsigned int *sockflags, sockflagsize;
	4976
	4977	/*
	4978	* Shim fdopen to identify sockets for my_fwrite later, since the stdio
	4979	* routines found in some versions of the CRTL can't deal with sockets.
	4980	* We don't shim the other file open routines since a socket isn't
	4981	* likely to be opened by a name.
	4982	*/
	4983	/{{{ FILE my_fdopen(int fd, const char mode)/
	4984	FILE my_fdopen(int fd, const char mode)
	4985	{
	4986	FILE fp = fdopen(fd, (char ) mode);
	4987
	4988	if (fp) {
	4989	unsigned int fdoff = fd / sizeof(unsigned int);
	4990	struct stat sbuf; /* native stat; we don't need flex_stat */
	4991	if (!sockflagsize \|\| fdoff > sockflagsize) {
	4992	if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
	4993	else New (1324,sockflags,fdoff+2,unsigned int);
	4994	memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
	4995	sockflagsize = fdoff + 2;
	4996	}
	4997	if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
	4998	sockflags[fdoff] \|= 1 << (fd % sizeof(unsigned int));
	4999	}
	5000	return fp;
	5001
	5002	}
	5003	/}}}/
	5004
	5005
	5006	/*
	5007	* Clear the corresponding bit when the (possibly) socket stream is closed.
	5008	* There still a small hole: we miss an implicit close which might occur
	5009	* via freopen(). >> Todo
	5010	*/
	5011	/{{{ int my_fclose(FILE fp)*/
	5012	int my_fclose(FILE *fp) {
	5013	if (fp) {
	5014	unsigned int fd = fileno(fp);
	5015	unsigned int fdoff = fd / sizeof(unsigned int);
	5016
	5017	if (sockflagsize && fdoff <= sockflagsize)
	5018	sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
	5019	}
	5020	return fclose(fp);
	5021	}
	5022	/}}}/
	5023
	5024
	5025	/*
	5026	* A simple fwrite replacement which outputs itmsz*nitm chars without
	5027	* introducing record boundaries every itmsz chars.
	5028	* We are using fputs, which depends on a terminating null. We may
	5029	* well be writing binary data, so we need to accommodate not only
	5030	* data with nulls sprinkled in the middle but also data with no null
	5031	* byte at the end.
	5032	*/
	5033	/{{{ int my_fwrite(const void src, size_t itmsz, size_t nitm, FILE dest)/
	5034	int
	5035	my_fwrite(const void src, size_t itmsz, size_t nitm, FILE dest)
	5036	{
	5037	register char cp, end, cpd, data;
	5038	register unsigned int fd = fileno(dest);
	5039	register unsigned int fdoff = fd / sizeof(unsigned int);
	5040	int retval;
	5041	int bufsize = itmsz * nitm + 1;
	5042
	5043	if (fdoff < sockflagsize &&
	5044	(sockflags[fdoff] \| 1 << (fd % sizeof(unsigned int)))) {
	5045	if (write(fd, src, itmsz * nitm) == EOF) return EOF;
	5046	return nitm;
	5047	}
	5048
	5049	_ckvmssts_noperl(lib$get_vm(&bufsize, &data));
	5050	memcpy( data, src, itmsz*nitm );
	5051	data[itmsz*nitm] = '\0';
	5052
	5053	end = data + itmsz * nitm;
	5054	retval = (int) nitm; /* on success return # items written */
	5055
	5056	cpd = data;
	5057	while (cpd <= end) {
	5058	for (cp = cpd; cp <= end; cp++) if (!*cp) break;
	5059	if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
	5060	if (cp < end)
	5061	if (fputc('\0',dest) == EOF) { retval = EOF; break; }
	5062	cpd = cp + 1;
	5063	}
	5064
	5065	if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
	5066	return retval;
	5067
	5068	} /* end of my_fwrite() */
	5069	/}}}/
	5070
	5071	/{{{ int my_flush(FILE fp)*/
	5072	int
	5073	Perl_my_flush(pTHX_ FILE *fp)
	5074	{
	5075	int res;
	5076	if ((res = fflush(fp)) == 0 && fp) {
	5077	#ifdef VMS_DO_SOCKETS
	5078	Stat_t s;
	5079	if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
	5080	#endif
	5081	res = fsync(fileno(fp));
	5082	}
	5083	/*
	5084	* If the flush succeeded but set end-of-file, we need to clear
	5085	* the error because our caller may check ferror(). BTW, this
	5086	* probably means we just flushed an empty file.
	5087	*/
	5088	if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
	5089
	5090	return res;
	5091	}
	5092	/}}}/
	5093
	5094	/*
	5095	* Here are replacements for the following Unix routines in the VMS environment:
	5096	* getpwuid Get information for a particular UIC or UID
	5097	* getpwnam Get information for a named user
	5098	* getpwent Get information for each user in the rights database
	5099	* setpwent Reset search to the start of the rights database
	5100	* endpwent Finish searching for users in the rights database
	5101	*
	5102	* getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
	5103	* (defined in pwd.h), which contains the following fields:-
	5104	* struct passwd {
	5105	* char *pw_name; Username (in lower case)
	5106	* char *pw_passwd; Hashed password
	5107	* unsigned int pw_uid; UIC
	5108	* unsigned int pw_gid; UIC group number
	5109	* char *pw_unixdir; Default device/directory (VMS-style)
	5110	* char *pw_gecos; Owner name
	5111	* char *pw_dir; Default device/directory (Unix-style)
	5112	* char *pw_shell; Default CLI name (eg. DCL)
	5113	* };
	5114	* If the specified user does not exist, getpwuid and getpwnam return NULL.
	5115	*
	5116	* pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
	5117	* not the UIC member number (eg. what's returned by getuid()),
	5118	* getpwuid() can accept either as input (if uid is specified, the caller's
	5119	* UIC group is used), though it won't recognise gid=0.
	5120	*
	5121	* Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
	5122	* information about other users in your group or in other groups, respectively.
	5123	* If the required privilege is not available, then these routines fill only
	5124	* the pw_name, pw_uid, and pw_gid fields (the others point to an empty
	5125	* string).
	5126	*
	5127	* By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
	5128	*/
	5129
	5130	/* sizes of various UAF record fields */
	5131	#define UAI$S_USERNAME 12
	5132	#define UAI$S_IDENT 31
	5133	#define UAI$S_OWNER 31
	5134	#define UAI$S_DEFDEV 31
	5135	#define UAI$S_DEFDIR 63
	5136	#define UAI$S_DEFCLI 31
	5137	#define UAI$S_PWD 8
	5138
	5139	#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
	5140	(uic).uic$v_member != UIC$K_WILD_MEMBER && \
	5141	(uic).uic$v_group != UIC$K_WILD_GROUP)
	5142
	5143	static char __empty[]= "";
	5144	static struct passwd __passwd_empty=
	5145	{(char ) __empty, (char ) __empty, 0, 0,
	5146	(char ) __empty, (char ) __empty, (char ) __empty, (char ) __empty};
	5147	static int contxt= 0;
	5148	static struct passwd __pwdcache;
	5149	static char __pw_namecache[UAI$S_IDENT+1];
	5150
	5151	/*
	5152	* This routine does most of the work extracting the user information.
	5153	*/
	5154	static int fillpasswd (pTHX_ const char name, struct passwd pwd)
	5155	{
	5156	static struct {
	5157	unsigned char length;
	5158	char pw_gecos[UAI$S_OWNER+1];
	5159	} owner;
	5160	static union uicdef uic;
	5161	static struct {
	5162	unsigned char length;
	5163	char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
	5164	} defdev;
	5165	static struct {
	5166	unsigned char length;
	5167	char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
	5168	} defdir;
	5169	static struct {
	5170	unsigned char length;
	5171	char pw_shell[UAI$S_DEFCLI+1];
	5172	} defcli;
	5173	static char pw_passwd[UAI$S_PWD+1];
	5174
	5175	static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
	5176	struct dsc$descriptor_s name_desc;
	5177	unsigned long int sts;
	5178
	5179	static struct itmlst_3 itmlst[]= {
	5180	{UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
	5181	{sizeof(uic), UAI$_UIC, &uic, &luic},
	5182	{UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
	5183	{UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
	5184	{UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
	5185	{UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
	5186	{0, 0, NULL, NULL}};
	5187
	5188	name_desc.dsc$w_length= strlen(name);
	5189	name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
	5190	name_desc.dsc$b_class= DSC$K_CLASS_S;
	5191	name_desc.dsc$a_pointer= (char *) name;
	5192
	5193	/* Note that sys$getuai returns many fields as counted strings. */
	5194	sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
	5195	if (sts == SS$_NOSYSPRV \|\| sts == SS$_NOGRPPRV \|\| sts == RMS$_RNF) {
	5196	set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
	5197	}
	5198	else { _ckvmssts(sts); }
	5199	if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
	5200
	5201	if ((int) owner.length < lowner) lowner= (int) owner.length;
	5202	if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
	5203	if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
	5204	if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
	5205	memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
	5206	owner.pw_gecos[lowner]= '\0';
	5207	defdev.pw_dir[ldefdev+ldefdir]= '\0';
	5208	defcli.pw_shell[ldefcli]= '\0';
	5209	if (valid_uic(uic)) {
	5210	pwd->pw_uid= uic.uic$l_uic;
	5211	pwd->pw_gid= uic.uic$v_group;
	5212	}
	5213	else
	5214	Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
	5215	pwd->pw_passwd= pw_passwd;
	5216	pwd->pw_gecos= owner.pw_gecos;
	5217	pwd->pw_dir= defdev.pw_dir;
	5218	pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
	5219	pwd->pw_shell= defcli.pw_shell;
	5220	if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
	5221	int ldir;
	5222	ldir= strlen(pwd->pw_unixdir) - 1;
	5223	if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
	5224	}
	5225	else
	5226	strcpy(pwd->pw_unixdir, pwd->pw_dir);
	5227	__mystrtolower(pwd->pw_unixdir);
	5228	return 1;
	5229	}
	5230
	5231	/*
	5232	* Get information for a named user.
	5233	*/
	5234	/{{{struct passwd getpwnam(char name)/
	5235	struct passwd Perl_my_getpwnam(pTHX_ char name)
	5236	{
	5237	struct dsc$descriptor_s name_desc;
	5238	union uicdef uic;
	5239	unsigned long int status, sts;
	5240
	5241	__pwdcache = __passwd_empty;
	5242	if (!fillpasswd(aTHX_ name, &__pwdcache)) {
	5243	/* We still may be able to determine pw_uid and pw_gid */
	5244	name_desc.dsc$w_length= strlen(name);
	5245	name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
	5246	name_desc.dsc$b_class= DSC$K_CLASS_S;
	5247	name_desc.dsc$a_pointer= (char *) name;
	5248	if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
	5249	__pwdcache.pw_uid= uic.uic$l_uic;
	5250	__pwdcache.pw_gid= uic.uic$v_group;
	5251	}
	5252	else {
	5253	if (sts == SS$_NOSUCHID \|\| sts == SS$_IVIDENT \|\| sts == RMS$_PRV) {
	5254	set_vaxc_errno(sts);
	5255	set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
	5256	return NULL;
	5257	}
	5258	else { _ckvmssts(sts); }
	5259	}
	5260	}
	5261	strncpy(__pw_namecache, name, sizeof(__pw_namecache));
	5262	__pw_namecache[sizeof __pw_namecache - 1] = '\0';
	5263	__pwdcache.pw_name= __pw_namecache;
	5264	return &__pwdcache;
	5265	} /* end of my_getpwnam() */
	5266	/}}}/
	5267
	5268	/*
	5269	* Get information for a particular UIC or UID.
	5270	* Called by my_getpwent with uid=-1 to list all users.
	5271	*/
	5272	/{{{struct passwd my_getpwuid(Uid_t uid)*/
	5273	struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
	5274	{
	5275	const $DESCRIPTOR(name_desc,__pw_namecache);
	5276	unsigned short lname;
	5277	union uicdef uic;
	5278	unsigned long int status;
	5279
	5280	if (uid == (unsigned int) -1) {
	5281	do {
	5282	status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
	5283	if (status == SS$_NOSUCHID \|\| status == RMS$_PRV) {
	5284	set_vaxc_errno(status);
	5285	set_errno(status == RMS$_PRV ? EACCES : EINVAL);
	5286	my_endpwent();
	5287	return NULL;
	5288	}
	5289	else { _ckvmssts(status); }
	5290	} while (!valid_uic (uic));
	5291	}
	5292	else {
	5293	uic.uic$l_uic= uid;
	5294	if (!uic.uic$v_group)
	5295	uic.uic$v_group= PerlProc_getgid();
	5296	if (valid_uic(uic))
	5297	status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
	5298	else status = SS$_IVIDENT;
	5299	if (status == SS$_IVIDENT \|\| status == SS$_NOSUCHID \|\|
	5300	status == RMS$_PRV) {
	5301	set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
	5302	return NULL;
	5303	}
	5304	else { _ckvmssts(status); }
	5305	}
	5306	__pw_namecache[lname]= '\0';
	5307	__mystrtolower(__pw_namecache);
	5308
	5309	__pwdcache = __passwd_empty;
	5310	__pwdcache.pw_name = __pw_namecache;
	5311
	5312	/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
	5313	The identifier's value is usually the UIC, but it doesn't have to be,
	5314	so if we can, we let fillpasswd update this. */
	5315	__pwdcache.pw_uid = uic.uic$l_uic;
	5316	__pwdcache.pw_gid = uic.uic$v_group;
	5317
	5318	fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
	5319	return &__pwdcache;
	5320
	5321	} /* end of my_getpwuid() */
	5322	/}}}/
	5323
	5324	/*
	5325	* Get information for next user.
	5326	*/
	5327	/{{{struct passwd my_getpwent()*/
	5328	struct passwd *Perl_my_getpwent(pTHX)
	5329	{
	5330	return (my_getpwuid((unsigned int) -1));
	5331	}
	5332	/}}}/
	5333
	5334	/*
	5335	* Finish searching rights database for users.
	5336	*/
	5337	/{{{void my_endpwent()/
	5338	void Perl_my_endpwent(pTHX)
	5339	{
	5340	if (contxt) {
	5341	_ckvmssts(sys$finish_rdb(&contxt));
	5342	contxt= 0;
	5343	}
	5344	}
	5345	/}}}/
	5346
	5347	#ifdef HOMEGROWN_POSIX_SIGNALS
	5348	/* Signal handling routines, pulled into the core from POSIX.xs.
	5349	*
	5350	* We need these for threads, so they've been rolled into the core,
	5351	* rather than left in POSIX.xs.
	5352	*
	5353	* (DRS, Oct 23, 1997)
	5354	*/
	5355
	5356	/* sigset_t is atomic under VMS, so these routines are easy */
	5357	/{{{int my_sigemptyset(sigset_t ) */
	5358	int my_sigemptyset(sigset_t *set) {
	5359	if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
	5360	*set = 0; return 0;
	5361	}
	5362	/}}}/
	5363
	5364
	5365	/{{{int my_sigfillset(sigset_t )*/
	5366	int my_sigfillset(sigset_t *set) {
	5367	int i;
	5368	if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
	5369	for (i = 0; i < NSIG; i++) *set \|= (1 << i);
	5370	return 0;
	5371	}
	5372	/}}}/
	5373
	5374
	5375	/{{{int my_sigaddset(sigset_t set, int sig)*/
	5376	int my_sigaddset(sigset_t *set, int sig) {
	5377	if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
	5378	if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
	5379	*set \|= (1 << (sig - 1));
	5380	return 0;
	5381	}
	5382	/}}}/
	5383
	5384
	5385	/{{{int my_sigdelset(sigset_t set, int sig)*/
	5386	int my_sigdelset(sigset_t *set, int sig) {
	5387	if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
	5388	if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
	5389	*set &= ~(1 << (sig - 1));
	5390	return 0;
	5391	}
	5392	/}}}/
	5393
	5394
	5395	/{{{int my_sigismember(sigset_t set, int sig)*/
	5396	int my_sigismember(sigset_t *set, int sig) {
	5397	if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
	5398	if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
	5399	*set & (1 << (sig - 1));
	5400	}
	5401	/}}}/
	5402
	5403
	5404	/{{{int my_sigprocmask(int how, sigset_t set, sigset_t oset)/
	5405	int my_sigprocmask(int how, sigset_t set, sigset_t oset) {
	5406	sigset_t tempmask;
	5407
	5408	/* If set and oset are both null, then things are badly wrong. Bail out. */
	5409	if ((oset == NULL) && (set == NULL)) {
	5410	set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
	5411	return -1;
	5412	}
	5413
	5414	/* If set's null, then we're just handling a fetch. */
	5415	if (set == NULL) {
	5416	tempmask = sigblock(0);
	5417	}
	5418	else {
	5419	switch (how) {
	5420	case SIG_SETMASK:
	5421	tempmask = sigsetmask(*set);
	5422	break;
	5423	case SIG_BLOCK:
	5424	tempmask = sigblock(*set);
	5425	break;
	5426	case SIG_UNBLOCK:
	5427	tempmask = sigblock(0);
	5428	sigsetmask(*oset & ~tempmask);
	5429	break;
	5430	default:
	5431	set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
	5432	return -1;
	5433	}
	5434	}
	5435
	5436	/* Did they pass us an oset? If so, stick our holding mask into it */
	5437	if (oset)
	5438	*oset = tempmask;
	5439
	5440	return 0;
	5441	}
	5442	/}}}/
	5443	#endif /* HOMEGROWN_POSIX_SIGNALS */
	5444
	5445
	5446	/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
	5447	* my_utime(), and flex_stat(), all of which operate on UTC unless
	5448	* VMSISH_TIMES is true.
	5449	*/
	5450	/* method used to handle UTC conversions:
	5451	* 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
	5452	*/
	5453	static int gmtime_emulation_type;
	5454	/* number of secs to add to UTC POSIX-style time to get local time */
	5455	static long int utc_offset_secs;
	5456
	5457	/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
	5458	* in vmsish.h. #undef them here so we can call the CRTL routines
	5459	* directly.
	5460	*/
	5461	#undef gmtime
	5462	#undef localtime
	5463	#undef time
	5464
	5465
	5466	/*
	5467	* DEC C previous to 6.0 corrupts the behavior of the /prefix
	5468	* qualifier with the extern prefix pragma. This provisional
	5469	* hack circumvents this prefix pragma problem in previous
	5470	* precompilers.
	5471	*/
	5472	#if defined(__VMS_VER) && __VMS_VER >= 70000000
	5473	# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
	5474	# pragma __extern_prefix save
	5475	# pragma __extern_prefix "" /* set to empty to prevent prefixing */
	5476	# define gmtime decc$__utctz_gmtime
	5477	# define localtime decc$__utctz_localtime
	5478	# define time decc$__utc_time
	5479	# pragma __extern_prefix restore
	5480
	5481	struct tm gmtime(), localtime();
	5482
	5483	# endif
	5484	#endif
	5485
	5486
	5487	static time_t toutc_dst(time_t loc) {
	5488	struct tm *rsltmp;
	5489
	5490	if ((rsltmp = localtime(&loc)) == NULL) return -1;
	5491	loc -= utc_offset_secs;
	5492	if (rsltmp->tm_isdst) loc -= 3600;
	5493	return loc;
	5494	}
	5495	#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
	5496	((gmtime_emulation_type \|\| my_time(NULL)), \
	5497	(gmtime_emulation_type == 1 ? toutc_dst(secs) : \
	5498	((secs) - utc_offset_secs))))
	5499
	5500	static time_t toloc_dst(time_t utc) {
	5501	struct tm *rsltmp;
	5502
	5503	utc += utc_offset_secs;
	5504	if ((rsltmp = localtime(&utc)) == NULL) return -1;
	5505	if (rsltmp->tm_isdst) utc += 3600;
	5506	return utc;
	5507	}
	5508	#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
	5509	((gmtime_emulation_type \|\| my_time(NULL)), \
	5510	(gmtime_emulation_type == 1 ? toloc_dst(secs) : \
	5511	((secs) + utc_offset_secs))))
	5512
	5513	#ifndef RTL_USES_UTC
	5514	/*
	5515
	5516	ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
	5517	DST starts on 1st sun of april at 02:00 std time
	5518	ends on last sun of october at 02:00 dst time
	5519	see the UCX management command reference, SET CONFIG TIMEZONE
	5520	for formatting info.
	5521
	5522	No, it's not as general as it should be, but then again, NOTHING
	5523	will handle UK times in a sensible way.
	5524	*/
	5525
	5526
	5527	/*
	5528	parse the DST start/end info:
	5529	(Jddd\|ddd\|Mmon.nth.dow)[/hh:mm:ss]
	5530	*/
	5531
	5532	static char *
	5533	tz_parse_startend(char s, struct tm w, int *past)
	5534	{
	5535	int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
	5536	int ly, dozjd, d, m, n, hour, min, sec, j, k;
	5537	time_t g;
	5538
	5539	if (!s) return 0;
	5540	if (!w) return 0;
	5541	if (!past) return 0;
	5542
	5543	ly = 0;
	5544	if (w->tm_year % 4 == 0) ly = 1;
	5545	if (w->tm_year % 100 == 0) ly = 0;
	5546	if (w->tm_year+1900 % 400 == 0) ly = 1;
	5547	if (ly) dinm[1]++;
	5548
	5549	dozjd = isdigit(*s);
	5550	if (s == 'J' \|\| s == 'j' \|\| dozjd) {
	5551	if (!dozjd && !isdigit(*++s)) return 0;
	5552	d = *s++ - '0';
	5553	if (isdigit(*s)) {
	5554	d = d10 + s++ - '0';
	5555	if (isdigit(*s)) {
	5556	d = d10 + s++ - '0';
	5557	}
	5558	}
	5559	if (d == 0) return 0;
	5560	if (d > 366) return 0;
	5561	d--;
	5562	if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
	5563	g = d * 86400;
	5564	dozjd = 1;
	5565	} else if (s == 'M' \|\| s == 'm') {
	5566	if (!isdigit(*++s)) return 0;
	5567	m = *s++ - '0';
	5568	if (isdigit(s)) m = 10m + *s++ - '0';
	5569	if (*s != '.') return 0;
	5570	if (!isdigit(*++s)) return 0;
	5571	n = *s++ - '0';
	5572	if (n < 1 \|\| n > 5) return 0;
	5573	if (*s != '.') return 0;
	5574	if (!isdigit(*++s)) return 0;
	5575	d = *s++ - '0';
	5576	if (d > 6) return 0;
	5577	}
	5578
	5579	if (*s == '/') {
	5580	if (!isdigit(*++s)) return 0;
	5581	hour = *s++ - '0';
	5582	if (isdigit(s)) hour = 10hour + *s++ - '0';
	5583	if (*s == ':') {
	5584	if (!isdigit(*++s)) return 0;
	5585	min = *s++ - '0';
	5586	if (isdigit(s)) min = 10min + *s++ - '0';
	5587	if (*s == ':') {
	5588	if (!isdigit(*++s)) return 0;
	5589	sec = *s++ - '0';
	5590	if (isdigit(s)) sec = 10sec + *s++ - '0';
	5591	}
	5592	}
	5593	} else {
	5594	hour = 2;
	5595	min = 0;
	5596	sec = 0;
	5597	}
	5598
	5599	if (dozjd) {
	5600	if (w->tm_yday < d) goto before;
	5601	if (w->tm_yday > d) goto after;
	5602	} else {
	5603	if (w->tm_mon+1 < m) goto before;
	5604	if (w->tm_mon+1 > m) goto after;
	5605
	5606	j = (42 + w->tm_wday - w->tm_mday)%7; /dow of mday 0 /
	5607	k = d - j; /* mday of first d */
	5608	if (k <= 0) k += 7;
	5609	k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
	5610	if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
	5611	if (w->tm_mday < k) goto before;
	5612	if (w->tm_mday > k) goto after;
	5613	}
	5614
	5615	if (w->tm_hour < hour) goto before;
	5616	if (w->tm_hour > hour) goto after;
	5617	if (w->tm_min < min) goto before;
	5618	if (w->tm_min > min) goto after;
	5619	if (w->tm_sec < sec) goto before;
	5620	goto after;
	5621
	5622	before:
	5623	*past = 0;
	5624	return s;
	5625	after:
	5626	*past = 1;
	5627	return s;
	5628	}
	5629
	5630
	5631
	5632
	5633	/* parse the offset: (+\|-)hh[:mm[:ss]] */
	5634
	5635	static char *
	5636	tz_parse_offset(char s, int offset)
	5637	{
	5638	int hour = 0, min = 0, sec = 0;
	5639	int neg = 0;
	5640	if (!s) return 0;
	5641	if (!offset) return 0;
	5642
	5643	if (*s == '-') {neg++; s++;}
	5644	if (*s == '+') s++;
	5645	if (!isdigit(*s)) return 0;
	5646	hour = *s++ - '0';
	5647	if (isdigit(s)) hour = hour10+(*s++ - '0');
	5648	if (hour > 24) return 0;
	5649	if (*s == ':') {
	5650	if (!isdigit(*++s)) return 0;
	5651	min = *s++ - '0';
	5652	if (isdigit(s)) min = min10 + (*s++ - '0');
	5653	if (min > 59) return 0;
	5654	if (*s == ':') {
	5655	if (!isdigit(*++s)) return 0;
	5656	sec = *s++ - '0';
	5657	if (isdigit(s)) sec = sec10 + (*s++ - '0');
	5658	if (sec > 59) return 0;
	5659	}
	5660	}
	5661
	5662	offset = (hour60+min)*60 + sec;
	5663	if (neg) offset = -offset;
	5664	return s;
	5665	}
	5666
	5667	/*
	5668	input time is w, whatever type of time the CRTL localtime() uses.
	5669	sets dst, the zone, and the gmtoff (seconds)
	5670
	5671	caches the value of TZ and UCX$TZ env variables; note that
	5672	my_setenv looks for these and sets a flag if they're changed
	5673	for efficiency.
	5674
	5675	We have to watch out for the "australian" case (dst starts in
	5676	october, ends in april)...flagged by "reverse" and checked by
	5677	scanning through the months of the previous year.
	5678
	5679	*/
	5680
	5681	static int
	5682	tz_parse(pTHX_ time_t w, int dst, char zone, int gmtoff)
	5683	{
	5684	time_t when;
	5685	struct tm *w2;
	5686	char s,s2;
	5687	char dstzone, tz, s_start, s_end;
	5688	int std_off, dst_off, isdst;
	5689	int y, dststart, dstend;
	5690	static char envtz[1025]; /* longer than any logical, symbol, ... */
	5691	static char ucxtz[1025];
	5692	static char reversed = 0;
	5693
	5694	if (!w) return 0;
	5695
	5696	if (tz_updated) {
	5697	tz_updated = 0;
	5698	reversed = -1; /* flag need to check */
	5699	envtz[0] = ucxtz[0] = '\0';
	5700	tz = my_getenv("TZ",0);
	5701	if (tz) strcpy(envtz, tz);
	5702	tz = my_getenv("UCX$TZ",0);
	5703	if (tz) strcpy(ucxtz, tz);
	5704	if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
	5705	}
	5706	tz = envtz;
	5707	if (!*tz) tz = ucxtz;
	5708
	5709	s = tz;
	5710	while (isalpha(*s)) s++;
	5711	s = tz_parse_offset(s, &std_off);
	5712	if (!s) return 0;
	5713	if (!s) { / no DST, hurray we're done! */
	5714	isdst = 0;
	5715	goto done;
	5716	}
	5717
	5718	dstzone = s;
	5719	while (isalpha(*s)) s++;
	5720	s2 = tz_parse_offset(s, &dst_off);
	5721	if (s2) {
	5722	s = s2;
	5723	} else {
	5724	dst_off = std_off - 3600;
	5725	}
	5726
	5727	if (!s) { / default dst start/end?? */
	5728	if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
	5729	s = strchr(ucxtz,',');
	5730	}
	5731	if (!s \|\| !s) s = ",M4.1.0,M10.5.0"; / we know we do dst, default rule */
	5732	}
	5733	if (*s != ',') return 0;
	5734
	5735	when = *w;
	5736	when = _toutc(when); /* convert to utc */
	5737	when = when - std_off; /* convert to pseudolocal time*/
	5738
	5739	w2 = localtime(&when);
	5740	y = w2->tm_year;
	5741	s_start = s+1;
	5742	s = tz_parse_startend(s_start,w2,&dststart);
	5743	if (!s) return 0;
	5744	if (*s != ',') return 0;
	5745
	5746	when = *w;
	5747	when = _toutc(when); /* convert to utc */
	5748	when = when - dst_off; /* convert to pseudolocal time*/
	5749	w2 = localtime(&when);
	5750	if (w2->tm_year != y) { /* spans a year, just check one time */
	5751	when += dst_off - std_off;
	5752	w2 = localtime(&when);
	5753	}
	5754	s_end = s+1;
	5755	s = tz_parse_startend(s_end,w2,&dstend);
	5756	if (!s) return 0;
	5757
	5758	if (reversed == -1) { /* need to check if start later than end */
	5759	int j, ds, de;
	5760
	5761	when = *w;
	5762	if (when < 236586400) {
	5763	when += 236586400;
	5764	} else {
	5765	when -= 365*86400;
	5766	}
	5767	w2 =localtime(&when);
	5768	when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
	5769
	5770	for (j = 0; j < 12; j++) {
	5771	w2 =localtime(&when);
	5772	(void) tz_parse_startend(s_start,w2,&ds);
	5773	(void) tz_parse_startend(s_end,w2,&de);
	5774	if (ds != de) break;
	5775	when += 30*86400;
	5776	}
	5777	reversed = 0;
	5778	if (de && !ds) reversed = 1;
	5779	}
	5780
	5781	isdst = dststart && !dstend;
	5782	if (reversed) isdst = dststart \|\| !dstend;
	5783
	5784	done:
	5785	if (dst) *dst = isdst;
	5786	if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
	5787	if (isdst) tz = dstzone;
	5788	if (zone) {
	5789	while(isalpha(tz)) zone++ = *tz++;
	5790	*zone = '\0';
	5791	}
	5792	return 1;
	5793	}
	5794
	5795	#endif /* !RTL_USES_UTC */
	5796
	5797	/* my_time(), my_localtime(), my_gmtime()
	5798	* By default traffic in UTC time values, using CRTL gmtime() or
	5799	* SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
	5800	* Note: We need to use these functions even when the CRTL has working
	5801	* UTC support, since they also handle C<use vmsish qw(times);>
	5802	*
	5803	* Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
	5804	* Modified by Charles Bailey <bailey@newman.upenn.edu>
	5805	*/
	5806
	5807	/{{{time_t my_time(time_t timep)*/
	5808	time_t Perl_my_time(pTHX_ time_t *timep)
	5809	{
	5810	time_t when;
	5811	struct tm *tm_p;
	5812
	5813	if (gmtime_emulation_type == 0) {
	5814	int dstnow;
	5815	time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
	5816	/* results of calls to gmtime() and localtime() */
	5817	/* for same &base */
	5818
	5819	gmtime_emulation_type++;
	5820	if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
	5821	char off[LNM$C_NAMLENGTH+1];;
	5822
	5823	gmtime_emulation_type++;
	5824	if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
	5825	gmtime_emulation_type++;
	5826	utc_offset_secs = 0;
	5827	Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
	5828	}
	5829	else { utc_offset_secs = atol(off); }
	5830	}
	5831	else { /* We've got a working gmtime() */
	5832	struct tm gmt, local;
	5833
	5834	gmt = *tm_p;
	5835	tm_p = localtime(&base);
	5836	local = *tm_p;
	5837	utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
	5838	utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
	5839	utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
	5840	utc_offset_secs += (local.tm_sec - gmt.tm_sec);
	5841	}
	5842	}
	5843
	5844	when = time(NULL);
	5845	# ifdef VMSISH_TIME
	5846	# ifdef RTL_USES_UTC
	5847	if (VMSISH_TIME) when = _toloc(when);
	5848	# else
	5849	if (!VMSISH_TIME) when = _toutc(when);
	5850	# endif
	5851	# endif
	5852	if (timep != NULL) *timep = when;
	5853	return when;
	5854
	5855	} /* end of my_time() */
	5856	/}}}/
	5857
	5858
	5859	/{{{struct tm my_gmtime(const time_t timep)/
	5860	struct tm *
	5861	Perl_my_gmtime(pTHX_ const time_t *timep)
	5862	{
	5863	char *p;
	5864	time_t when;
	5865	struct tm *rsltmp;
	5866
	5867	if (timep == NULL) {
	5868	set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
	5869	return NULL;
	5870	}
	5871	if (timep == 0) gmtime_emulation_type = 0; / possibly reset TZ */
	5872
	5873	when = *timep;
	5874	# ifdef VMSISH_TIME
	5875	if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
	5876	# endif
	5877	# ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
	5878	return gmtime(&when);
	5879	# else
	5880	/* CRTL localtime() wants local time as input, so does no tz correction */
	5881	rsltmp = localtime(&when);
	5882	if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
	5883	return rsltmp;
	5884	#endif
	5885	} /* end of my_gmtime() */
	5886	/}}}/
	5887
	5888
	5889	/{{{struct tm my_localtime(const time_t timep)/
	5890	struct tm *
	5891	Perl_my_localtime(pTHX_ const time_t *timep)
	5892	{
	5893	time_t when, whenutc;
	5894	struct tm *rsltmp;
	5895	int dst, offset;
	5896
	5897	if (timep == NULL) {
	5898	set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
	5899	return NULL;
	5900	}
	5901	if (timep == 0) gmtime_emulation_type = 0; / possibly reset TZ */
	5902	if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
	5903
	5904	when = *timep;
	5905	# ifdef RTL_USES_UTC
	5906	# ifdef VMSISH_TIME
	5907	if (VMSISH_TIME) when = _toutc(when);
	5908	# endif
	5909	/* CRTL localtime() wants UTC as input, does tz correction itself */
	5910	return localtime(&when);
	5911
	5912	# else /* !RTL_USES_UTC */
	5913	whenutc = when;
	5914	# ifdef VMSISH_TIME
	5915	if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
	5916	if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
	5917	# endif
	5918	dst = -1;
	5919	#ifndef RTL_USES_UTC
	5920	if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
	5921	when = whenutc - offset; /* pseudolocal time*/
	5922	}
	5923	# endif
	5924	/* CRTL localtime() wants local time as input, so does no tz correction */
	5925	rsltmp = localtime(&when);
	5926	if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
	5927	return rsltmp;
	5928	# endif
	5929
	5930	} /* end of my_localtime() */
	5931	/}}}/
	5932
	5933	/* Reset definitions for later calls */
	5934	#define gmtime(t) my_gmtime(t)
	5935	#define localtime(t) my_localtime(t)
	5936	#define time(t) my_time(t)
	5937
	5938
	5939	/* my_utime - update modification time of a file
	5940	* calling sequence is identical to POSIX utime(), but under
	5941	* VMS only the modification time is changed; ODS-2 does not
	5942	* maintain access times. Restrictions differ from the POSIX
	5943	* definition in that the time can be changed as long as the
	5944	* caller has permission to execute the necessary IO$_MODIFY $QIO;
	5945	* no separate checks are made to insure that the caller is the
	5946	* owner of the file or has special privs enabled.
	5947	* Code here is based on Joe Meadows' FILE utility.
	5948	*/
	5949
	5950	/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
	5951	* to VMS epoch (01-JAN-1858 00:00:00.00)
	5952	* in 100 ns intervals.
	5953	*/
	5954	static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
	5955
	5956	/{{{int my_utime(char path, struct utimbuf utimes)/
	5957	int Perl_my_utime(pTHX_ char file, struct utimbuf utimes)
	5958	{
	5959	register int i;
	5960	long int bintime[2], len = 2, lowbit, unixtime,
	5961	secscale = 10000000; /* seconds --> 100 ns intervals */
	5962	unsigned long int chan, iosb[2], retsts;
	5963	char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
	5964	struct FAB myfab = cc$rms_fab;
	5965	struct NAM mynam = cc$rms_nam;
	5966	#if defined (__DECC) && defined (__VAX)
	5967	/* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
	5968	* at least through VMS V6.1, which causes a type-conversion warning.
	5969	*/
	5970	# pragma message save
	5971	# pragma message disable cvtdiftypes
	5972	#endif
	5973	struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
	5974	struct fibdef myfib;
	5975	#if defined (__DECC) && defined (__VAX)
	5976	/* This should be right after the declaration of myatr, but due
	5977	* to a bug in VAX DEC C, this takes effect a statement early.
	5978	*/
	5979	# pragma message restore
	5980	#endif
	5981	struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
	5982	devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
	5983	fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
	5984
	5985	if (file == NULL \|\| *file == '\0') {
	5986	set_errno(ENOENT);
	5987	set_vaxc_errno(LIB$_INVARG);
	5988	return -1;
	5989	}
	5990	if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
	5991
	5992	if (utimes != NULL) {
	5993	/* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
	5994	* to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
	5995	* Since time_t is unsigned long int, and lib$emul takes a signed long int
	5996	* as input, we force the sign bit to be clear by shifting unixtime right
	5997	* one bit, then multiplying by an extra factor of 2 in lib$emul().
	5998	*/
	5999	lowbit = (utimes->modtime & 1) ? secscale : 0;
	6000	unixtime = (long int) utimes->modtime;
	6001	# ifdef VMSISH_TIME
	6002	/* If input was UTC; convert to local for sys svc */
	6003	if (!VMSISH_TIME) unixtime = _toloc(unixtime);
	6004	# endif
	6005	unixtime >>= 1; secscale <<= 1;
	6006	retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
	6007	if (!(retsts & 1)) {
	6008	set_errno(EVMSERR);
	6009	set_vaxc_errno(retsts);
	6010	return -1;
	6011	}
	6012	retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
	6013	if (!(retsts & 1)) {
	6014	set_errno(EVMSERR);
	6015	set_vaxc_errno(retsts);
	6016	return -1;
	6017	}
	6018	}
	6019	else {
	6020	/* Just get the current time in VMS format directly */
	6021	retsts = sys$gettim(bintime);
	6022	if (!(retsts & 1)) {
	6023	set_errno(EVMSERR);
	6024	set_vaxc_errno(retsts);
	6025	return -1;
	6026	}
	6027	}
	6028
	6029	myfab.fab$l_fna = vmsspec;
	6030	myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
	6031	myfab.fab$l_nam = &mynam;
	6032	mynam.nam$l_esa = esa;
	6033	mynam.nam$b_ess = (unsigned char) sizeof esa;
	6034	mynam.nam$l_rsa = rsa;
	6035	mynam.nam$b_rss = (unsigned char) sizeof rsa;
	6036
	6037	/* Look for the file to be affected, letting RMS parse the file
	6038	* specification for us as well. I have set errno using only
	6039	* values documented in the utime() man page for VMS POSIX.
	6040	*/
	6041	retsts = sys$parse(&myfab,0,0);
	6042	if (!(retsts & 1)) {
	6043	set_vaxc_errno(retsts);
	6044	if (retsts == RMS$_PRV) set_errno(EACCES);
	6045	else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
	6046	else set_errno(EVMSERR);
	6047	return -1;
	6048	}
	6049	retsts = sys$search(&myfab,0,0);
	6050	if (!(retsts & 1)) {
	6051	mynam.nam$b_nop \|= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
	6052	myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
	6053	set_vaxc_errno(retsts);
	6054	if (retsts == RMS$_PRV) set_errno(EACCES);
	6055	else if (retsts == RMS$_FNF) set_errno(ENOENT);
	6056	else set_errno(EVMSERR);
	6057	return -1;
	6058	}
	6059
	6060	devdsc.dsc$w_length = mynam.nam$b_dev;
	6061	devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
	6062
	6063	retsts = sys$assign(&devdsc,&chan,0,0);
	6064	if (!(retsts & 1)) {
	6065	mynam.nam$b_nop \|= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
	6066	myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
	6067	set_vaxc_errno(retsts);
	6068	if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
	6069	else if (retsts == SS$_NOPRIV) set_errno(EACCES);
	6070	else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
	6071	else set_errno(EVMSERR);
	6072	return -1;
	6073	}
	6074
	6075	fnmdsc.dsc$a_pointer = mynam.nam$l_name;
	6076	fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
	6077
	6078	memset((void *) &myfib, 0, sizeof myfib);
	6079	#if defined(__DECC) \|\| defined(__DECCXX)
	6080	for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
	6081	for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
	6082	/* This prevents the revision time of the file being reset to the current
	6083	* time as a result of our IO$_MODIFY $QIO. */
	6084	myfib.fib$l_acctl = FIB$M_NORECORD;
	6085	#else
	6086	for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
	6087	for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
	6088	myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
	6089	#endif
	6090	retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
	6091	mynam.nam$b_nop \|= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
	6092	myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
	6093	_ckvmssts(sys$dassgn(chan));
	6094	if (retsts & 1) retsts = iosb[0];
	6095	if (!(retsts & 1)) {
	6096	set_vaxc_errno(retsts);
	6097	if (retsts == SS$_NOPRIV) set_errno(EACCES);
	6098	else set_errno(EVMSERR);
	6099	return -1;
	6100	}
	6101
	6102	return 0;
	6103	} /* end of my_utime() */
	6104	/}}}/
	6105
	6106	/*
	6107	* flex_stat, flex_fstat
	6108	* basic stat, but gets it right when asked to stat
	6109	* a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
	6110	*/
	6111
	6112	/* encode_dev packs a VMS device name string into an integer to allow
	6113	* simple comparisons. This can be used, for example, to check whether two
	6114	* files are located on the same device, by comparing their encoded device
	6115	* names. Even a string comparison would not do, because stat() reuses the
	6116	* device name buffer for each call; so without encode_dev, it would be
	6117	* necessary to save the buffer and use strcmp (this would mean a number of
	6118	* changes to the standard Perl code, to say nothing of what a Perl script
	6119	* would have to do.
	6120	*
	6121	* The device lock id, if it exists, should be unique (unless perhaps compared
	6122	* with lock ids transferred from other nodes). We have a lock id if the disk is
	6123	* mounted cluster-wide, which is when we tend to get long (host-qualified)
	6124	* device names. Thus we use the lock id in preference, and only if that isn't
	6125	* available, do we try to pack the device name into an integer (flagged by
	6126	* the sign bit (LOCKID_MASK) being set).
	6127	*
	6128	* Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
	6129	* name and its encoded form, but it seems very unlikely that we will find
	6130	* two files on different disks that share the same encoded device names,
	6131	* and even more remote that they will share the same file id (if the test
	6132	* is to check for the same file).
	6133	*
	6134	* A better method might be to use sys$device_scan on the first call, and to
	6135	* search for the device, returning an index into the cached array.
	6136	* The number returned would be more intelligable.
	6137	* This is probably not worth it, and anyway would take quite a bit longer
	6138	* on the first call.
	6139	*/
	6140	#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
	6141	static mydev_t encode_dev (pTHX_ const char *dev)
	6142	{
	6143	int i;
	6144	unsigned long int f;
	6145	mydev_t enc;
	6146	char c;
	6147	const char *q;
	6148
	6149	if (!dev \|\| !dev[0]) return 0;
	6150
	6151	#if LOCKID_MASK
	6152	{
	6153	struct dsc$descriptor_s dev_desc;
	6154	unsigned long int status, lockid, item = DVI$_LOCKID;
	6155
	6156	/* For cluster-mounted disks, the disk lock identifier is unique, so we
	6157	can try that first. */
	6158	dev_desc.dsc$w_length = strlen (dev);
	6159	dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
	6160	dev_desc.dsc$b_class = DSC$K_CLASS_S;
	6161	dev_desc.dsc$a_pointer = (char *) dev;
	6162	_ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
	6163	if (lockid) return (lockid & ~LOCKID_MASK);
	6164	}
	6165	#endif
	6166
	6167	/* Otherwise we try to encode the device name */
	6168	enc = 0;
	6169	f = 1;
	6170	i = 0;
	6171	for (q = dev + strlen(dev); q--; q >= dev) {
	6172	if (isdigit (*q))
	6173	c= (*q) - '0';
	6174	else if (isalpha (toupper (*q)))
	6175	c= toupper (*q) - 'A' + (char)10;
	6176	else
	6177	continue; /* Skip '$'s */
	6178	i++;
	6179	if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
	6180	if (i>1) f *= 36;
	6181	enc += f * (unsigned long int) c;
	6182	}
	6183	return (enc \| LOCKID_MASK); /* May have already overflowed into bit 31 */
	6184
	6185	} /* end of encode_dev() */
	6186
	6187	static char namecache[NAM$C_MAXRSS+1];
	6188
	6189	static int
	6190	is_null_device(name)
	6191	const char *name;
	6192	{
	6193	/* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
	6194	The underscore prefix, controller letter, and unit number are
	6195	independently optional; for our purposes, the colon punctuation
	6196	is not. The colon can be trailed by optional directory and/or
	6197	filename, but two consecutive colons indicates a nodename rather
	6198	than a device. [pr] */
	6199	if (*name == '_') ++name;
	6200	if (tolower(*name++) != 'n') return 0;
	6201	if (tolower(*name++) != 'l') return 0;
	6202	if (tolower(*name) == 'a') ++name;
	6203	if (*name == '0') ++name;
	6204	return (name++ == ':') && (name != ':');
	6205	}
	6206
	6207	/* Do the permissions allow some operation? Assumes PL_statcache already set. */
	6208	/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
	6209	* subset of the applicable information.
	6210	*/
	6211	bool
	6212	Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
	6213	{
	6214	char fname_phdev[NAM$C_MAXRSS+1];
	6215	if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
	6216	else {
	6217	char fname[NAM$C_MAXRSS+1];
	6218	unsigned long int retsts;
	6219	struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
	6220	namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
	6221
	6222	/* If the struct mystat is stale, we're OOL; stat() overwrites the
	6223	device name on successive calls */
	6224	devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
	6225	devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
	6226	namdsc.dsc$a_pointer = fname;
	6227	namdsc.dsc$w_length = sizeof fname - 1;
	6228
	6229	retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
	6230	&namdsc,&namdsc.dsc$w_length,0,0);
	6231	if (retsts & 1) {
	6232	fname[namdsc.dsc$w_length] = '\0';
	6233	/*
	6234	* lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
	6235	* but if someone has redefined that logical, Perl gets very lost. Since
	6236	* we have the physical device name from the stat buffer, just paste it on.
	6237	*/
	6238	strcpy( fname_phdev, statbufp->st_devnam );
	6239	strcat( fname_phdev, strrchr(fname, ':') );
	6240
	6241	return cando_by_name(bit,effective,fname_phdev);
	6242	}
	6243	else if (retsts == SS$_NOSUCHDEV \|\| retsts == SS$_NOSUCHFILE) {
	6244	Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
	6245	return FALSE;
	6246	}
	6247	_ckvmssts(retsts);
	6248	return FALSE; /* Should never get to here */
	6249	}
	6250	} /* end of cando() */
	6251	/}}}/
	6252
	6253
	6254	/{{{I32 cando_by_name(I32 bit, Uid_t effective, char fname)*/
	6255	I32
	6256	Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
	6257	{
	6258	static char usrname[L_cuserid];
	6259	static struct dsc$descriptor_s usrdsc =
	6260	{0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
	6261	char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
	6262	unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
	6263	unsigned short int retlen;
	6264	struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
	6265	union prvdef curprv;
	6266	struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
	6267	{sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
	6268	struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
	6269	{0,0,0,0}};
	6270
	6271	if (!fname \|\| !*fname) return FALSE;
	6272	/* Make sure we expand logical names, since sys$check_access doesn't */
	6273	if (!strpbrk(fname,"/]>:")) {
	6274	strcpy(fileified,fname);
	6275	while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
	6276	fname = fileified;
	6277	}
	6278	if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
	6279	retlen = namdsc.dsc$w_length = strlen(vmsname);
	6280	namdsc.dsc$a_pointer = vmsname;
	6281	if (vmsname[retlen-1] == ']' \|\| vmsname[retlen-1] == '>' \|\|
	6282	vmsname[retlen-1] == ':') {
	6283	if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
	6284	namdsc.dsc$w_length = strlen(fileified);
	6285	namdsc.dsc$a_pointer = fileified;
	6286	}
	6287
	6288	if (!usrdsc.dsc$w_length) {
	6289	cuserid(usrname);
	6290	usrdsc.dsc$w_length = strlen(usrname);
	6291	}
	6292
	6293	switch (bit) {
	6294	case S_IXUSR: case S_IXGRP: case S_IXOTH:
	6295	access = ARM$M_EXECUTE; break;
	6296	case S_IRUSR: case S_IRGRP: case S_IROTH:
	6297	access = ARM$M_READ; break;
	6298	case S_IWUSR: case S_IWGRP: case S_IWOTH:
	6299	access = ARM$M_WRITE; break;
	6300	case S_IDUSR: case S_IDGRP: case S_IDOTH:
	6301	access = ARM$M_DELETE; break;
	6302	default:
	6303	return FALSE;
	6304	}
	6305
	6306	retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
	6307	if (retsts == SS$_NOPRIV \|\| retsts == SS$_NOSUCHOBJECT \|\|
	6308	retsts == SS$_INVFILFOROP \|\| retsts == RMS$_FNF \|\| retsts == RMS$_SYN \|\|
	6309	retsts == RMS$_DIR \|\| retsts == RMS$_DEV \|\| retsts == RMS$_DNF) {
	6310	set_vaxc_errno(retsts);
	6311	if (retsts == SS$_NOPRIV) set_errno(EACCES);
	6312	else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
	6313	else set_errno(ENOENT);
	6314	return FALSE;
	6315	}
	6316	if (retsts == SS$_NORMAL) {
	6317	if (!privused) return TRUE;
	6318	/* We can get access, but only by using privs. Do we have the
	6319	necessary privs currently enabled? */
	6320	_ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
	6321	if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
	6322	if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
	6323	!curprv.prv$v_bypass) return FALSE;
	6324	if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
	6325	!curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
	6326	if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
	6327	return TRUE;
	6328	}
	6329	if (retsts == SS$_ACCONFLICT) {
	6330	return TRUE;
	6331	}
	6332	_ckvmssts(retsts);
	6333
	6334	return FALSE; /* Should never get here */
	6335
	6336	} /* end of cando_by_name() */
	6337	/}}}/
	6338
	6339
	6340	/{{{ int flex_fstat(int fd, Stat_t statbuf)*/
	6341	int
	6342	Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
	6343	{
	6344	if (!fstat(fd,(stat_t *) statbufp)) {
	6345	if (statbufp == (Stat_t ) &PL_statcache) namecache == '\0';
	6346	statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
	6347	# ifdef RTL_USES_UTC
	6348	# ifdef VMSISH_TIME
	6349	if (VMSISH_TIME) {
	6350	statbufp->st_mtime = _toloc(statbufp->st_mtime);
	6351	statbufp->st_atime = _toloc(statbufp->st_atime);
	6352	statbufp->st_ctime = _toloc(statbufp->st_ctime);
	6353	}
	6354	# endif
	6355	# else
	6356	# ifdef VMSISH_TIME
	6357	if (!VMSISH_TIME) { /* Return UTC instead of local time */
	6358	# else
	6359	if (1) {
	6360	# endif
	6361	statbufp->st_mtime = _toutc(statbufp->st_mtime);
	6362	statbufp->st_atime = _toutc(statbufp->st_atime);
	6363	statbufp->st_ctime = _toutc(statbufp->st_ctime);
	6364	}
	6365	#endif
	6366	return 0;
	6367	}
	6368	return -1;
	6369
	6370	} /* end of flex_fstat() */
	6371	/}}}/
	6372
	6373	/{{{ int flex_stat(const char fspec, Stat_t statbufp)/
	6374	int
	6375	Perl_flex_stat(pTHX_ const char fspec, Stat_t statbufp)
	6376	{
	6377	char fileified[NAM$C_MAXRSS+1];
	6378	char temp_fspec[NAM$C_MAXRSS+300];
	6379	int retval = -1;
	6380
	6381	if (!fspec) return retval;
	6382	strcpy(temp_fspec, fspec);
	6383	if (statbufp == (Stat_t *) &PL_statcache)
	6384	do_tovmsspec(temp_fspec,namecache,0);
	6385	if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
	6386	memset(statbufp,0,sizeof *statbufp);
	6387	statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
	6388	statbufp->st_mode = S_IFBLK \| S_IREAD \| S_IWRITE \| S_IEXEC;
	6389	statbufp->st_uid = 0x00010001;
	6390	statbufp->st_gid = 0x0001;
	6391	time((time_t *)&statbufp->st_mtime);
	6392	statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
	6393	return 0;
	6394	}
	6395
	6396	/* Try for a directory name first. If fspec contains a filename without
	6397	* a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
	6398	* and sea:[wine.dark]water. exist, we prefer the directory here.
	6399	* Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
	6400	* not sea:[wine.dark]., if the latter exists. If the intended target is
	6401	* the file with null type, specify this by calling flex_stat() with
	6402	* a '.' at the end of fspec.
	6403	*/
	6404	if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
	6405	retval = stat(fileified,(stat_t *) statbufp);
	6406	if (!retval && statbufp == (Stat_t *) &PL_statcache)
	6407	strcpy(namecache,fileified);
	6408	}
	6409	if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
	6410	if (!retval) {
	6411	statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
	6412	# ifdef RTL_USES_UTC
	6413	# ifdef VMSISH_TIME
	6414	if (VMSISH_TIME) {
	6415	statbufp->st_mtime = _toloc(statbufp->st_mtime);
	6416	statbufp->st_atime = _toloc(statbufp->st_atime);
	6417	statbufp->st_ctime = _toloc(statbufp->st_ctime);
	6418	}
	6419	# endif
	6420	# else
	6421	# ifdef VMSISH_TIME
	6422	if (!VMSISH_TIME) { /* Return UTC instead of local time */
	6423	# else
	6424	if (1) {
	6425	# endif
	6426	statbufp->st_mtime = _toutc(statbufp->st_mtime);
	6427	statbufp->st_atime = _toutc(statbufp->st_atime);
	6428	statbufp->st_ctime = _toutc(statbufp->st_ctime);
	6429	}
	6430	# endif
	6431	}
	6432	return retval;
	6433
	6434	} /* end of flex_stat() */
	6435	/}}}/
	6436
	6437
	6438	/{{{char my_getlogin()*/
	6439	/* VMS cuserid == Unix getlogin, except calling sequence */
	6440	char *
	6441	my_getlogin()
	6442	{
	6443	static char user[L_cuserid];
	6444	return cuserid(user);
	6445	}
	6446	/}}}/
	6447
	6448
	6449	/* rmscopy - copy a file using VMS RMS routines
	6450	*
	6451	* Copies contents and attributes of spec_in to spec_out, except owner
	6452	* and protection information. Name and type of spec_in are used as
	6453	* defaults for spec_out. The third parameter specifies whether rmscopy()
	6454	* should try to propagate timestamps from the input file to the output file.
	6455	* If it is less than 0, no timestamps are preserved. If it is 0, then
	6456	* rmscopy() will behave similarly to the DCL COPY command: timestamps are
	6457	* propagated to the output file at creation iff the output file specification
	6458	* did not contain an explicit name or type, and the revision date is always
	6459	* updated at the end of the copy operation. If it is greater than 0, then
	6460	* it is interpreted as a bitmask, in which bit 0 indicates that timestamps
	6461	* other than the revision date should be propagated, and bit 1 indicates
	6462	* that the revision date should be propagated.
	6463	*
	6464	* Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
	6465	*
	6466	* Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
	6467	* Incorporates, with permission, some code from EZCOPY by Tim Adye
	6468	* <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
	6469	* as part of the Perl standard distribution under the terms of the
	6470	* GNU General Public License or the Perl Artistic License. Copies
	6471	* of each may be found in the Perl standard distribution.
	6472	*/
	6473	/{{{int rmscopy(char src, char dst, int preserve_dates)/
	6474	int
	6475	Perl_rmscopy(pTHX_ char spec_in, char spec_out, int preserve_dates)
	6476	{
	6477	char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
	6478	rsa[NAM$C_MAXRSS], ubf[32256];
	6479	unsigned long int i, sts, sts2;
	6480	struct FAB fab_in, fab_out;
	6481	struct RAB rab_in, rab_out;
	6482	struct NAM nam;
	6483	struct XABDAT xabdat;
	6484	struct XABFHC xabfhc;
	6485	struct XABRDT xabrdt;
	6486	struct XABSUM xabsum;
	6487
	6488	if (!spec_in \|\| !*spec_in \|\| !do_tovmsspec(spec_in,vmsin,1) \|\|
	6489	!spec_out \|\| !*spec_out \|\| !do_tovmsspec(spec_out,vmsout,1)) {
	6490	set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
	6491	return 0;
	6492	}
	6493
	6494	fab_in = cc$rms_fab;
	6495	fab_in.fab$l_fna = vmsin;
	6496	fab_in.fab$b_fns = strlen(vmsin);
	6497	fab_in.fab$b_shr = FAB$M_SHRPUT \| FAB$M_UPI;
	6498	fab_in.fab$b_fac = FAB$M_BIO \| FAB$M_GET;
	6499	fab_in.fab$l_fop = FAB$M_SQO;
	6500	fab_in.fab$l_nam = &nam;
	6501	fab_in.fab$l_xab = (void *) &xabdat;
	6502
	6503	nam = cc$rms_nam;
	6504	nam.nam$l_rsa = rsa;
	6505	nam.nam$b_rss = sizeof(rsa);
	6506	nam.nam$l_esa = esa;
	6507	nam.nam$b_ess = sizeof (esa);
	6508	nam.nam$b_esl = nam.nam$b_rsl = 0;
	6509
	6510	xabdat = cc$rms_xabdat; /* To get creation date */
	6511	xabdat.xab$l_nxt = (void *) &xabfhc;
	6512
	6513	xabfhc = cc$rms_xabfhc; /* To get record length */
	6514	xabfhc.xab$l_nxt = (void *) &xabsum;
	6515
	6516	xabsum = cc$rms_xabsum; /* To get key and area information */
	6517
	6518	if (!((sts = sys$open(&fab_in)) & 1)) {
	6519	set_vaxc_errno(sts);
	6520	switch (sts) {
	6521	case RMS$_FNF: case RMS$_DNF:
	6522	set_errno(ENOENT); break;
	6523	case RMS$_DIR:
	6524	set_errno(ENOTDIR); break;
	6525	case RMS$_DEV:
	6526	set_errno(ENODEV); break;
	6527	case RMS$_SYN:
	6528	set_errno(EINVAL); break;
	6529	case RMS$_PRV:
	6530	set_errno(EACCES); break;
	6531	default:
	6532	set_errno(EVMSERR);
	6533	}
	6534	return 0;
	6535	}
	6536
	6537	fab_out = fab_in;
	6538	fab_out.fab$w_ifi = 0;
	6539	fab_out.fab$b_fac = FAB$M_BIO \| FAB$M_PUT;
	6540	fab_out.fab$b_shr = FAB$M_SHRGET \| FAB$M_UPI;
	6541	fab_out.fab$l_fop = FAB$M_SQO;
	6542	fab_out.fab$l_fna = vmsout;
	6543	fab_out.fab$b_fns = strlen(vmsout);
	6544	fab_out.fab$l_dna = nam.nam$l_name;
	6545	fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
	6546
	6547	if (preserve_dates == 0) { /* Act like DCL COPY */
	6548	nam.nam$b_nop = NAM$M_SYNCHK;
	6549	fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
	6550	if (!((sts = sys$parse(&fab_out)) & 1)) {
	6551	set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
	6552	set_vaxc_errno(sts);
	6553	return 0;
	6554	}
	6555	fab_out.fab$l_xab = (void *) &xabdat;
	6556	if (nam.nam$l_fnb & (NAM$M_EXP_NAME \| NAM$M_EXP_TYPE)) preserve_dates = 1;
	6557	}
	6558	fab_out.fab$l_nam = (void ) 0; / Done with NAM block */
	6559	if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
	6560	preserve_dates =0; /* bitmask from this point forward */
	6561
	6562	if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
	6563	if (!((sts = sys$create(&fab_out)) & 1)) {
	6564	set_vaxc_errno(sts);
	6565	switch (sts) {
	6566	case RMS$_DNF:
	6567	set_errno(ENOENT); break;
	6568	case RMS$_DIR:
	6569	set_errno(ENOTDIR); break;
	6570	case RMS$_DEV:
	6571	set_errno(ENODEV); break;
	6572	case RMS$_SYN:
	6573	set_errno(EINVAL); break;
	6574	case RMS$_PRV:
	6575	set_errno(EACCES); break;
	6576	default:
	6577	set_errno(EVMSERR);
	6578	}
	6579	return 0;
	6580	}
	6581	fab_out.fab$l_fop \|= FAB$M_DLT; /* in case we have to bail out */
	6582	if (preserve_dates & 2) {
	6583	/* sys$close() will process xabrdt, not xabdat */
	6584	xabrdt = cc$rms_xabrdt;
	6585	#ifndef __GNUC__
	6586	xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
	6587	#else
	6588	/* gcc doesn't like the assignment, since its prototype for xab$q_rdt
	6589	* is unsigned long[2], while DECC & VAXC use a struct */
	6590	memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
	6591	#endif
	6592	fab_out.fab$l_xab = (void *) &xabrdt;
	6593	}
	6594
	6595	rab_in = cc$rms_rab;
	6596	rab_in.rab$l_fab = &fab_in;
	6597	rab_in.rab$l_rop = RAB$M_BIO;
	6598	rab_in.rab$l_ubf = ubf;
	6599	rab_in.rab$w_usz = sizeof ubf;
	6600	if (!((sts = sys$connect(&rab_in)) & 1)) {
	6601	sys$close(&fab_in); sys$close(&fab_out);
	6602	set_errno(EVMSERR); set_vaxc_errno(sts);
	6603	return 0;
	6604	}
	6605
	6606	rab_out = cc$rms_rab;
	6607	rab_out.rab$l_fab = &fab_out;
	6608	rab_out.rab$l_rbf = ubf;
	6609	if (!((sts = sys$connect(&rab_out)) & 1)) {
	6610	sys$close(&fab_in); sys$close(&fab_out);
	6611	set_errno(EVMSERR); set_vaxc_errno(sts);
	6612	return 0;
	6613	}
	6614
	6615	while ((sts = sys$read(&rab_in))) { /* always true */
	6616	if (sts == RMS$_EOF) break;
	6617	rab_out.rab$w_rsz = rab_in.rab$w_rsz;
	6618	if (!(sts & 1) \|\| !((sts = sys$write(&rab_out)) & 1)) {
	6619	sys$close(&fab_in); sys$close(&fab_out);
	6620	set_errno(EVMSERR); set_vaxc_errno(sts);
	6621	return 0;
	6622	}
	6623	}
	6624
	6625	fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
	6626	sys$close(&fab_in); sys$close(&fab_out);
	6627	sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
	6628	if (!(sts & 1)) {
	6629	set_errno(EVMSERR); set_vaxc_errno(sts);
	6630	return 0;
	6631	}
	6632
	6633	return 1;
	6634
	6635	} /* end of rmscopy() */
	6636	/}}}/
	6637
	6638
	6639	/*** The following glue provides 'hooks' to make some of the routines
	6640	* from this file available from Perl. These routines are sufficiently
	6641	* basic, and are required sufficiently early in the build process,
	6642	* that's it's nice to have them available to miniperl as well as the
	6643	* full Perl, so they're set up here instead of in an extension. The
	6644	* Perl code which handles importation of these names into a given
	6645	* package lives in [.VMS]Filespec.pm in @INC.
	6646	*/
	6647
	6648	void
	6649	rmsexpand_fromperl(pTHX_ CV *cv)
	6650	{
	6651	dXSARGS;
	6652	char fspec, defspec = NULL, *rslt;
	6653	STRLEN n_a;
	6654
	6655	if (!items \|\| items > 2)
	6656	Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
	6657	fspec = SvPV(ST(0),n_a);
	6658	if (!fspec \|\| !*fspec) XSRETURN_UNDEF;
	6659	if (items == 2) defspec = SvPV(ST(1),n_a);
	6660
	6661	rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
	6662	ST(0) = sv_newmortal();
	6663	if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
	6664	XSRETURN(1);
	6665	}
	6666
	6667	void
	6668	vmsify_fromperl(pTHX_ CV *cv)
	6669	{
	6670	dXSARGS;
	6671	char *vmsified;
	6672	STRLEN n_a;
	6673
	6674	if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
	6675	vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
	6676	ST(0) = sv_newmortal();
	6677	if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
	6678	XSRETURN(1);
	6679	}
	6680
	6681	void
	6682	unixify_fromperl(pTHX_ CV *cv)
	6683	{
	6684	dXSARGS;
	6685	char *unixified;
	6686	STRLEN n_a;
	6687
	6688	if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
	6689	unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
	6690	ST(0) = sv_newmortal();
	6691	if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
	6692	XSRETURN(1);
	6693	}
	6694
	6695	void
	6696	fileify_fromperl(pTHX_ CV *cv)
	6697	{
	6698	dXSARGS;
	6699	char *fileified;
	6700	STRLEN n_a;
	6701
	6702	if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
	6703	fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
	6704	ST(0) = sv_newmortal();
	6705	if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
	6706	XSRETURN(1);
	6707	}
	6708
	6709	void
	6710	pathify_fromperl(pTHX_ CV *cv)
	6711	{
	6712	dXSARGS;
	6713	char *pathified;
	6714	STRLEN n_a;
	6715
	6716	if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
	6717	pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
	6718	ST(0) = sv_newmortal();
	6719	if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
	6720	XSRETURN(1);
	6721	}
	6722
	6723	void
	6724	vmspath_fromperl(pTHX_ CV *cv)
	6725	{
	6726	dXSARGS;
	6727	char *vmspath;
	6728	STRLEN n_a;
	6729
	6730	if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
	6731	vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
	6732	ST(0) = sv_newmortal();
	6733	if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
	6734	XSRETURN(1);
	6735	}
	6736
	6737	void
	6738	unixpath_fromperl(pTHX_ CV *cv)
	6739	{
	6740	dXSARGS;
	6741	char *unixpath;
	6742	STRLEN n_a;
	6743
	6744	if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
	6745	unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
	6746	ST(0) = sv_newmortal();
	6747	if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
	6748	XSRETURN(1);
	6749	}
	6750
	6751	void
	6752	candelete_fromperl(pTHX_ CV *cv)
	6753	{
	6754	dXSARGS;
	6755	char fspec[NAM$C_MAXRSS+1], *fsp;
	6756	SV *mysv;
	6757	IO *io;
	6758	STRLEN n_a;
	6759
	6760	if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
	6761
	6762	mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
	6763	if (SvTYPE(mysv) == SVt_PVGV) {
	6764	if (!(io = GvIOp(mysv)) \|\| !PerlIO_getname(IoIFP(io),fspec)) {
	6765	set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
	6766	ST(0) = &PL_sv_no;
	6767	XSRETURN(1);
	6768	}
	6769	fsp = fspec;
	6770	}
	6771	else {
	6772	if (mysv != ST(0) \|\| !(fsp = SvPV(mysv,n_a)) \|\| !*fsp) {
	6773	set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
	6774	ST(0) = &PL_sv_no;
	6775	XSRETURN(1);
	6776	}
	6777	}
	6778
	6779	ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
	6780	XSRETURN(1);
	6781	}
	6782
	6783	void
	6784	rmscopy_fromperl(pTHX_ CV *cv)
	6785	{
	6786	dXSARGS;
	6787	char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], inp, outp;
	6788	int date_flag;
	6789	struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
	6790	outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
	6791	unsigned long int sts;
	6792	SV *mysv;
	6793	IO *io;
	6794	STRLEN n_a;
	6795
	6796	if (items < 2 \|\| items > 3)
	6797	Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
	6798
	6799	mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
	6800	if (SvTYPE(mysv) == SVt_PVGV) {
	6801	if (!(io = GvIOp(mysv)) \|\| !PerlIO_getname(IoIFP(io),inspec)) {
	6802	set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
	6803	ST(0) = &PL_sv_no;
	6804	XSRETURN(1);
	6805	}
	6806	inp = inspec;
	6807	}
	6808	else {
	6809	if (mysv != ST(0) \|\| !(inp = SvPV(mysv,n_a)) \|\| !*inp) {
	6810	set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
	6811	ST(0) = &PL_sv_no;
	6812	XSRETURN(1);
	6813	}
	6814	}
	6815	mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
	6816	if (SvTYPE(mysv) == SVt_PVGV) {
	6817	if (!(io = GvIOp(mysv)) \|\| !PerlIO_getname(IoIFP(io),outspec)) {
	6818	set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
	6819	ST(0) = &PL_sv_no;
	6820	XSRETURN(1);
	6821	}
	6822	outp = outspec;
	6823	}
	6824	else {
	6825	if (mysv != ST(1) \|\| !(outp = SvPV(mysv,n_a)) \|\| !*outp) {
	6826	set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
	6827	ST(0) = &PL_sv_no;
	6828	XSRETURN(1);
	6829	}
	6830	}
	6831	date_flag = (items == 3) ? SvIV(ST(2)) : 0;
	6832
	6833	ST(0) = boolSV(rmscopy(inp,outp,date_flag));
	6834	XSRETURN(1);
	6835	}
	6836
	6837
	6838	void
	6839	mod2fname(pTHX_ CV *cv)
	6840	{
	6841	dXSARGS;
	6842	char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
	6843	workbuff[NAM$C_MAXRSS*1 + 1];
	6844	int total_namelen = 3, counter, num_entries;
	6845	/* ODS-5 ups this, but we want to be consistent, so... */
	6846	int max_name_len = 39;
	6847	AV in_array = (AV )SvRV(ST(0));
	6848
	6849	num_entries = av_len(in_array);
	6850
	6851	/* All the names start with PL_. */
	6852	strcpy(ultimate_name, "PL_");
	6853
	6854	/* Clean up our working buffer */
	6855	Zero(work_name, sizeof(work_name), char);
	6856
	6857	/* Run through the entries and build up a working name */
	6858	for(counter = 0; counter <= num_entries; counter++) {
	6859	/* If it's not the first name then tack on a __ */
	6860	if (counter) {
	6861	strcat(work_name, "__");
	6862	}
	6863	strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
	6864	PL_na));
	6865	}
	6866
	6867	/* Check to see if we actually have to bother...*/
	6868	if (strlen(work_name) + 3 <= max_name_len) {
	6869	strcat(ultimate_name, work_name);
	6870	} else {
	6871	/* It's too darned big, so we need to go strip. We use the same */
	6872	/* algorithm as xsubpp does. First, strip out doubled __ */
	6873	char source, dest, last;
	6874	dest = workbuff;
	6875	last = 0;
	6876	for (source = work_name; *source; source++) {
	6877	if (last == *source && last == '_') {
	6878	continue;
	6879	}
	6880	dest++ = source;
	6881	last = *source;
	6882	}
	6883	/* Go put it back */
	6884	strcpy(work_name, workbuff);
	6885	/* Is it still too big? */
	6886	if (strlen(work_name) + 3 > max_name_len) {
	6887	/* Strip duplicate letters */
	6888	last = 0;
	6889	dest = workbuff;
	6890	for (source = work_name; *source; source++) {
	6891	if (last == toupper(*source)) {
	6892	continue;
	6893	}
	6894	dest++ = source;
	6895	last = toupper(*source);
	6896	}
	6897	strcpy(work_name, workbuff);
	6898	}
	6899
	6900	/* Is it still too big? */
	6901	if (strlen(work_name) + 3 > max_name_len) {
	6902	/* Too bad, we truncate */
	6903	work_name[max_name_len - 2] = 0;
	6904	}
	6905	strcat(ultimate_name, work_name);
	6906	}
	6907
	6908	/* Okay, return it */
	6909	ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
	6910	XSRETURN(1);
	6911	}
	6912
	6913	void
	6914	hushexit_fromperl(pTHX_ CV *cv)
	6915	{
	6916	dXSARGS;
	6917
	6918	if (items > 0) {
	6919	VMSISH_HUSHED = SvTRUE(ST(0));
	6920	}
	6921	ST(0) = boolSV(VMSISH_HUSHED);
	6922	XSRETURN(1);
	6923	}
	6924
	6925	void
	6926	Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
	6927	struct interp_intern *dst)
	6928	{
	6929	memcpy(dst,src,sizeof(struct interp_intern));
	6930	}
	6931
	6932	void
	6933	Perl_sys_intern_clear(pTHX)
	6934	{
	6935	}
	6936
	6937	void
	6938	Perl_sys_intern_init(pTHX)
	6939	{
	6940	int ix = RAND_MAX;
	6941	float x;
	6942
	6943	VMSISH_HUSHED = 0;
	6944
	6945	x = (float)ix;
	6946	MY_INV_RAND_MAX = 1./x;
	6947	}
	6948
	6949
	6950
	6951	void
	6952	init_os_extras()
	6953	{
	6954	dTHX;
	6955	char* file = __FILE__;
	6956	char temp_buff[512];
	6957	if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
	6958	no_translate_barewords = TRUE;
	6959	} else {
	6960	no_translate_barewords = FALSE;
	6961	}
	6962
	6963	newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
	6964	newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
	6965	newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
	6966	newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
	6967	newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
	6968	newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
	6969	newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
	6970	newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
	6971	newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
	6972	newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
	6973	newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
	6974
	6975	store_pipelocs(aTHX);
	6976
	6977	return;
	6978	}
	6979
	6980	/* End of vms.c */