Remove unused static function popen_translate from vms.c.

[perl5.git] / vms / vms.c

/*    vms.c
 *
 *    VMS-specific routines for perl5
 *
 *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
 *    2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 *    Please see Changes*.* or the Perl Repository Browser for revision history.
 */

/*
 *   Yet small as was their hunted band
 *   still fell and fearless was each hand,
 *   and strong deeds they wrought yet oft,
 *   and loved the woods, whose ways more soft
 *   them seemed than thralls of that black throne
 *   to live and languish in halls of stone.
 *        "The Lay of Leithian", Canto II, lines 135-40
 *
 *     [p.162 of _The Lays of Beleriand_]
 */
 
#include <acedef.h>
#include <acldef.h>
#include <armdef.h>
#include <atrdef.h>
#include <chpdef.h>
#include <clidef.h>
#include <climsgdef.h>
#include <dcdef.h>
#include <descrip.h>
#include <devdef.h>
#include <dvidef.h>
#include <fibdef.h>
#include <float.h>
#include <fscndef.h>
#include <iodef.h>
#include <jpidef.h>
#include <kgbdef.h>
#include <libclidef.h>
#include <libdef.h>
#include <lib$routines.h>
#include <lnmdef.h>
#include <msgdef.h>
#include <ossdef.h>
#if __CRTL_VER >= 70301000 && !defined(__VAX)
#include <ppropdef.h>
#endif
#include <prvdef.h>
#include <psldef.h>
#include <rms.h>
#include <shrdef.h>
#include <ssdef.h>
#include <starlet.h>
#include <strdef.h>
#include <str$routines.h>
#include <syidef.h>
#include <uaidef.h>
#include <uicdef.h>
#include <stsdef.h>
#include <rmsdef.h>
#if __CRTL_VER >= 70000000 /* FIXME to earliest version */
#include <efndef.h>
#define NO_EFN EFN$C_ENF
#else
#define NO_EFN 0;
#endif

#if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
int   decc$feature_get_index(const char *name);
char* decc$feature_get_name(int index);
int   decc$feature_get_value(int index, int mode);
int   decc$feature_set_value(int index, int mode, int value);
#else
#include <unixlib.h>
#endif

#pragma member_alignment save
#pragma nomember_alignment longword
struct item_list_3 {
	unsigned short len;
	unsigned short code;
	void * bufadr;
	unsigned short * retadr;
};
#pragma member_alignment restore

#if __CRTL_VER >= 70300000 && !defined(__VAX)

static int set_feature_default(const char *name, int value)
{
    int status;
    int index;

    index = decc$feature_get_index(name);

    status = decc$feature_set_value(index, 1, value);
    if (index == -1 || (status == -1)) {
      return -1;
    }

    status = decc$feature_get_value(index, 1);
    if (status != value) {
      return -1;
    }

return 0;
}
#endif

/* Older versions of ssdef.h don't have these */
#ifndef SS$_INVFILFOROP
#  define SS$_INVFILFOROP 3930
#endif
#ifndef SS$_NOSUCHOBJECT
#  define SS$_NOSUCHOBJECT 2696
#endif

/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
#define PERLIO_NOT_STDIO 0 

/* Don't replace system definitions of vfork, getenv, lstat, and stat, 
 * code below needs to get to the underlying CRTL routines. */
#define DONT_MASK_RTL_CALLS
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
/* Anticipating future expansion in lexical warnings . . . */
#ifndef WARN_INTERNAL
#  define WARN_INTERNAL WARN_MISC
#endif

#ifdef VMS_LONGNAME_SUPPORT
#include <libfildef.h>
#endif

#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
#  define RTL_USES_UTC 1
#endif

#if !defined(__VAX) && __CRTL_VER >= 80200000
#ifdef lstat
#undef lstat
#endif
#else
#ifdef lstat
#undef lstat
#endif
#define lstat(_x, _y) stat(_x, _y)
#endif

/* Routine to create a decterm for use with the Perl debugger */
/* No headers, this information was found in the Programming Concepts Manual */

static int (*decw_term_port)
   (const struct dsc$descriptor_s * display,
    const struct dsc$descriptor_s * setup_file,
    const struct dsc$descriptor_s * customization,
    struct dsc$descriptor_s * result_device_name,
    unsigned short * result_device_name_length,
    void * controller,
    void * char_buffer,
    void * char_change_buffer) = 0;

/* gcc's header files don't #define direct access macros
 * corresponding to VAXC's variant structs */
#ifdef __GNUC__
#  define uic$v_format uic$r_uic_form.uic$v_format
#  define uic$v_group uic$r_uic_form.uic$v_group
#  define uic$v_member uic$r_uic_form.uic$v_member
#  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
#  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
#  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
#  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
#endif

#if defined(NEED_AN_H_ERRNO)
dEXT int h_errno;
#endif

#ifdef __DECC
#pragma message disable pragma
#pragma member_alignment save
#pragma nomember_alignment longword
#pragma message save
#pragma message disable misalgndmem
#endif
struct itmlst_3 {
  unsigned short int buflen;
  unsigned short int itmcode;
  void *bufadr;
  unsigned short int *retlen;
};

struct filescan_itmlst_2 {
    unsigned short length;
    unsigned short itmcode;
    char * component;
};

struct vs_str_st {
    unsigned short length;
    char str[65536];
};

#ifdef __DECC
#pragma message restore
#pragma member_alignment restore
#endif

#define do_fileify_dirspec(a,b,c,d)	mp_do_fileify_dirspec(aTHX_ a,b,c,d)
#define do_pathify_dirspec(a,b,c,d)	mp_do_pathify_dirspec(aTHX_ a,b,c,d)
#define do_tovmsspec(a,b,c,d)		mp_do_tovmsspec(aTHX_ a,b,c,0,d)
#define do_tovmspath(a,b,c,d)		mp_do_tovmspath(aTHX_ a,b,c,d)
#define do_rmsexpand(a,b,c,d,e,f,g)	mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
#define do_vms_realpath(a,b,c)		mp_do_vms_realpath(aTHX_ a,b,c)
#define do_vms_realname(a,b,c)		mp_do_vms_realname(aTHX_ a,b,c)
#define do_tounixspec(a,b,c,d)		mp_do_tounixspec(aTHX_ a,b,c,d)
#define do_tounixpath(a,b,c,d)		mp_do_tounixpath(aTHX_ a,b,c,d)
#define do_vms_case_tolerant(a)		mp_do_vms_case_tolerant(a)
#define expand_wild_cards(a,b,c,d)	mp_expand_wild_cards(aTHX_ a,b,c,d)
#define getredirection(a,b)		mp_getredirection(aTHX_ a,b)

static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);

static char *  int_rmsexpand_vms(
    const char * filespec, char * outbuf, unsigned opts);
static char * int_rmsexpand_tovms(
    const char * filespec, char * outbuf, unsigned opts);
static char *int_tovmsspec
   (const char *path, char *buf, int dir_flag, int * utf8_flag);
static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);

/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
#define PERL_LNM_MAX_ALLOWED_INDEX 127

/* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 * the Perl facility.
 */
#define PERL_LNM_MAX_ITER 10

  /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
#if __CRTL_VER >= 70302000 && !defined(__VAX)
#define MAX_DCL_SYMBOL		(8192)
#define MAX_DCL_LINE_LENGTH	(4096 - 4)
#else
#define MAX_DCL_SYMBOL		(1024)
#define MAX_DCL_LINE_LENGTH	(1024 - 4)
#endif

static char *__mystrtolower(char *str)
{
  if (str) for (; *str; ++str) *str= tolower(*str);
  return str;
}

static struct dsc$descriptor_s fildevdsc = 
  { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
static struct dsc$descriptor_s crtlenvdsc = 
  { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
static struct dsc$descriptor_s **env_tables = defenv;
static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */

/* True if we shouldn't treat barewords as logicals during directory */
/* munching */ 
static int no_translate_barewords;

#ifndef RTL_USES_UTC
static int tz_updated = 1;
#endif

/* DECC Features that may need to affect how Perl interprets
 * displays filename information
 */
static int decc_disable_to_vms_logname_translation = 1;
static int decc_disable_posix_root = 1;
int decc_efs_case_preserve = 0;
static int decc_efs_charset = 0;
static int decc_efs_charset_index = -1;
static int decc_filename_unix_no_version = 0;
static int decc_filename_unix_only = 0;
int decc_filename_unix_report = 0;
int decc_posix_compliant_pathnames = 0;
int decc_readdir_dropdotnotype = 0;
static int vms_process_case_tolerant = 1;
int vms_vtf7_filenames = 0;
int gnv_unix_shell = 0;
static int vms_unlink_all_versions = 0;
static int vms_posix_exit = 0;

/* bug workarounds if needed */
int decc_bug_devnull = 1;
int decc_dir_barename = 0;
int vms_bug_stat_filename = 0;

static int vms_debug_on_exception = 0;
static int vms_debug_fileify = 0;

/* Simple logical name translation */
static int simple_trnlnm
   (const char * logname,
    char * value,
    int value_len)
{
    const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
    const unsigned long attr = LNM$M_CASE_BLIND;
    struct dsc$descriptor_s name_dsc;
    int status;
    unsigned short result;
    struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
                                {0, 0, 0, 0}};

    name_dsc.dsc$w_length = strlen(logname);
    name_dsc.dsc$a_pointer = (char *)logname;
    name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
    name_dsc.dsc$b_class = DSC$K_CLASS_S;

    status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);

    if ($VMS_STATUS_SUCCESS(status)) {

	 /* Null terminate and return the string */
	/*--------------------------------------*/
	value[result] = 0;
        return result;
    }

    return 0;
}


/* Is this a UNIX file specification?
 *   No longer a simple check with EFS file specs
 *   For now, not a full check, but need to
 *   handle POSIX ^UP^ specifications
 *   Fixing to handle ^/ cases would require
 *   changes to many other conversion routines.
 */

static int is_unix_filespec(const char *path)
{
int ret_val;
const char * pch1;

    ret_val = 0;
    if (strncmp(path,"\"^UP^",5) != 0) {
	pch1 = strchr(path, '/');
	if (pch1 != NULL)
	    ret_val = 1;
	else {

	    /* If the user wants UNIX files, "." needs to be treated as in UNIX */
	    if (decc_filename_unix_report || decc_filename_unix_only) {
	    if (strcmp(path,".") == 0)
		ret_val = 1;
	    }
	}
    }
    return ret_val;
}

/* This routine converts a UCS-2 character to be VTF-7 encoded.
 */

static void ucs2_to_vtf7
   (char *outspec,
    unsigned long ucs2_char,
    int * output_cnt)
{
unsigned char * ucs_ptr;
int hex;

    ucs_ptr = (unsigned char *)&ucs2_char;

    outspec[0] = '^';
    outspec[1] = 'U';
    hex = (ucs_ptr[1] >> 4) & 0xf;
    if (hex < 0xA)
	outspec[2] = hex + '0';
    else
	outspec[2] = (hex - 9) + 'A';
    hex = ucs_ptr[1] & 0xF;
    if (hex < 0xA)
	outspec[3] = hex + '0';
    else {
	outspec[3] = (hex - 9) + 'A';
    }
    hex = (ucs_ptr[0] >> 4) & 0xf;
    if (hex < 0xA)
	outspec[4] = hex + '0';
    else
	outspec[4] = (hex - 9) + 'A';
    hex = ucs_ptr[1] & 0xF;
    if (hex < 0xA)
	outspec[5] = hex + '0';
    else {
	outspec[5] = (hex - 9) + 'A';
    }
    *output_cnt = 6;
}


/* This handles the conversion of a UNIX extended character set to a ^
 * escaped VMS character.
 * in a UNIX file specification.
 *
 * The output count variable contains the number of characters added
 * to the output string.
 *
 * The return value is the number of characters read from the input string
 */
static int copy_expand_unix_filename_escape
  (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
{
int count;
int utf8_flag;

    utf8_flag = 0;
    if (utf8_fl)
      utf8_flag = *utf8_fl;

    count = 0;
    *output_cnt = 0;
    if (*inspec >= 0x80) {
	if (utf8_fl && vms_vtf7_filenames) {
	unsigned long ucs_char;

	    ucs_char = 0;

	    if ((*inspec & 0xE0) == 0xC0) {
		/* 2 byte Unicode */
		ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
		if (ucs_char >= 0x80) {
		    ucs2_to_vtf7(outspec, ucs_char, output_cnt);
		    return 2;
		}
	    } else if ((*inspec & 0xF0) == 0xE0) {
		/* 3 byte Unicode */
		ucs_char = ((inspec[0] & 0xF) << 12) + 
		   ((inspec[1] & 0x3f) << 6) +
		   (inspec[2] & 0x3f);
		if (ucs_char >= 0x800) {
		    ucs2_to_vtf7(outspec, ucs_char, output_cnt);
		    return 3;
		}

#if 0 /* I do not see longer sequences supported by OpenVMS */
      /* Maybe some one can fix this later */
	    } else if ((*inspec & 0xF8) == 0xF0) {
		/* 4 byte Unicode */
		/* UCS-4 to UCS-2 */
	    } else if ((*inspec & 0xFC) == 0xF8) {
		/* 5 byte Unicode */
		/* UCS-4 to UCS-2 */
	    } else if ((*inspec & 0xFE) == 0xFC) {
		/* 6 byte Unicode */
		/* UCS-4 to UCS-2 */
#endif
	    }
	}

	/* High bit set, but not a Unicode character! */

	/* Non printing DECMCS or ISO Latin-1 character? */
	if (*inspec <= 0x9F) {
	int hex;
	    outspec[0] = '^';
	    outspec++;
	    hex = (*inspec >> 4) & 0xF;
	    if (hex < 0xA)
		outspec[1] = hex + '0';
	    else {
		outspec[1] = (hex - 9) + 'A';
	    }
	    hex = *inspec & 0xF;
	    if (hex < 0xA)
		outspec[2] = hex + '0';
	    else {
		outspec[2] = (hex - 9) + 'A';
	    }
	    *output_cnt = 3;
	    return 1;
	} else if (*inspec == 0xA0) {
	    outspec[0] = '^';
	    outspec[1] = 'A';
	    outspec[2] = '0';
	    *output_cnt = 3;
	    return 1;
	} else if (*inspec == 0xFF) {
	    outspec[0] = '^';
	    outspec[1] = 'F';
	    outspec[2] = 'F';
	    *output_cnt = 3;
	    return 1;
	}
	*outspec = *inspec;
	*output_cnt = 1;
	return 1;
    }

    /* Is this a macro that needs to be passed through?
     * Macros start with $( and an alpha character, followed
     * by a string of alpha numeric characters ending with a )
     * If this does not match, then encode it as ODS-5.
     */
    if ((inspec[0] == '$') && (inspec[1] == '(')) {
    int tcnt;

	if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
	    tcnt = 3;
	    outspec[0] = inspec[0];
	    outspec[1] = inspec[1];
	    outspec[2] = inspec[2];

	    while(isalnum(inspec[tcnt]) ||
		  (inspec[2] == '.') || (inspec[2] == '_')) {
		outspec[tcnt] = inspec[tcnt];
		tcnt++;
	    }
	    if (inspec[tcnt] == ')') {
		outspec[tcnt] = inspec[tcnt];
		tcnt++;
		*output_cnt = tcnt;
		return tcnt;
	    }
	}
    }

    switch (*inspec) {
    case 0x7f:
	outspec[0] = '^';
	outspec[1] = '7';
	outspec[2] = 'F';
	*output_cnt = 3;
	return 1;
	break;
    case '?':
	if (decc_efs_charset == 0)
	  outspec[0] = '%';
	else
	  outspec[0] = '?';
	*output_cnt = 1;
	return 1;
	break;
    case '.':
    case '~':
    case '!':
    case '#':
    case '&':
    case '\'':
    case '`':
    case '(':
    case ')':
    case '+':
    case '@':
    case '{':
    case '}':
    case ',':
    case ';':
    case '[':
    case ']':
    case '%':
    case '^':
    case '\\':
        /* Don't escape again if following character is 
         * already something we escape.
         */
        if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
	    *outspec = *inspec;
	    *output_cnt = 1;
	    return 1;
	    break;
        }
        /* But otherwise fall through and escape it. */
    case '=':
	/* Assume that this is to be escaped */
	outspec[0] = '^';
	outspec[1] = *inspec;
	*output_cnt = 2;
	return 1;
	break;
    case ' ': /* space */
	/* Assume that this is to be escaped */
	outspec[0] = '^';
	outspec[1] = '_';
	*output_cnt = 2;
	return 1;
	break;
    default:
	*outspec = *inspec;
	*output_cnt = 1;
	return 1;
	break;
    }
}


/* This handles the expansion of a '^' prefix to the proper character
 * in a UNIX file specification.
 *
 * The output count variable contains the number of characters added
 * to the output string.
 *
 * The return value is the number of characters read from the input
 * string
 */
static int copy_expand_vms_filename_escape
  (char *outspec, const char *inspec, int *output_cnt)
{
int count;
int scnt;

    count = 0;
    *output_cnt = 0;
    if (*inspec == '^') {
	inspec++;
	switch (*inspec) {
        /* Spaces and non-trailing dots should just be passed through, 
         * but eat the escape character.
         */
	case '.':
	    *outspec = *inspec;
	    count += 2;
	    (*output_cnt)++;
	    break;
	case '_': /* space */
	    *outspec = ' ';
	    count += 2;
	    (*output_cnt)++;
	    break;
	case '^':
            /* Hmm.  Better leave the escape escaped. */
            outspec[0] = '^';
            outspec[1] = '^';
	    count += 2;
	    (*output_cnt) += 2;
	    break;
	case 'U': /* Unicode - FIX-ME this is wrong. */
	    inspec++;
	    count++;
	    scnt = strspn(inspec, "0123456789ABCDEFabcdef");
	    if (scnt == 4) {
		unsigned int c1, c2;
		scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
		outspec[0] = c1 & 0xff;
		outspec[1] = c2 & 0xff;
		if (scnt > 1) {
		    (*output_cnt) += 2;
		    count += 4;
		}
	    }
	    else {
		/* Error - do best we can to continue */
		*outspec = 'U';
		outspec++;
		(*output_cnt++);
		*outspec = *inspec;
		count++;
		(*output_cnt++);
	    }
	    break;
	default:
	    scnt = strspn(inspec, "0123456789ABCDEFabcdef");
	    if (scnt == 2) {
		/* Hex encoded */
		unsigned int c1;
		scnt = sscanf(inspec, "%2x", &c1);
		outspec[0] = c1 & 0xff;
		if (scnt > 0) {
		    (*output_cnt++);
		    count += 2;
	        }
	    }
	    else {
		*outspec = *inspec;
		count++;
		(*output_cnt++);
	    }
	}
    }
    else {
	*outspec = *inspec;
	count++;
	(*output_cnt)++;
    }
    return count;
}

/* vms_split_path - Verify that the input file specification is a
 * VMS format file specification, and provide pointers to the components of
 * it.  With EFS format filenames, this is virtually the only way to
 * parse a VMS path specification into components.
 *
 * If the sum of the components do not add up to the length of the
 * string, then the passed file specification is probably a UNIX style
 * path.
 */
static int vms_split_path
   (const char * path,
    char * * volume,
    int * vol_len,
    char * * root,
    int * root_len,
    char * * dir,
    int * dir_len,
    char * * name,
    int * name_len,
    char * * ext,
    int * ext_len,
    char * * version,
    int * ver_len)
{
struct dsc$descriptor path_desc;
int status;
unsigned long flags;
int ret_stat;
struct filescan_itmlst_2 item_list[9];
const int filespec = 0;
const int nodespec = 1;
const int devspec = 2;
const int rootspec = 3;
const int dirspec = 4;
const int namespec = 5;
const int typespec = 6;
const int verspec = 7;

    /* Assume the worst for an easy exit */
    ret_stat = -1;
    *volume = NULL;
    *vol_len = 0;
    *root = NULL;
    *root_len = 0;
    *dir = NULL;
    *name = NULL;
    *name_len = 0;
    *ext = NULL;
    *ext_len = 0;
    *version = NULL;
    *ver_len = 0;

    path_desc.dsc$a_pointer = (char *)path; /* cast ok */
    path_desc.dsc$w_length = strlen(path);
    path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
    path_desc.dsc$b_class = DSC$K_CLASS_S;

    /* Get the total length, if it is shorter than the string passed
     * then this was probably not a VMS formatted file specification
     */
    item_list[filespec].itmcode = FSCN$_FILESPEC;
    item_list[filespec].length = 0;
    item_list[filespec].component = NULL;

    /* If the node is present, then it gets considered as part of the
     * volume name to hopefully make things simple.
     */
    item_list[nodespec].itmcode = FSCN$_NODE;
    item_list[nodespec].length = 0;
    item_list[nodespec].component = NULL;

    item_list[devspec].itmcode = FSCN$_DEVICE;
    item_list[devspec].length = 0;
    item_list[devspec].component = NULL;

    /* root is a special case,  adding it to either the directory or
     * the device components will probably complicate things for the
     * callers of this routine, so leave it separate.
     */
    item_list[rootspec].itmcode = FSCN$_ROOT;
    item_list[rootspec].length = 0;
    item_list[rootspec].component = NULL;

    item_list[dirspec].itmcode = FSCN$_DIRECTORY;
    item_list[dirspec].length = 0;
    item_list[dirspec].component = NULL;

    item_list[namespec].itmcode = FSCN$_NAME;
    item_list[namespec].length = 0;
    item_list[namespec].component = NULL;

    item_list[typespec].itmcode = FSCN$_TYPE;
    item_list[typespec].length = 0;
    item_list[typespec].component = NULL;

    item_list[verspec].itmcode = FSCN$_VERSION;
    item_list[verspec].length = 0;
    item_list[verspec].component = NULL;

    item_list[8].itmcode = 0;
    item_list[8].length = 0;
    item_list[8].component = NULL;

    status = sys$filescan
       ((const struct dsc$descriptor_s *)&path_desc, item_list,
	&flags, NULL, NULL);
    _ckvmssts_noperl(status); /* All failure status values indicate a coding error */

    /* If we parsed it successfully these two lengths should be the same */
    if (path_desc.dsc$w_length != item_list[filespec].length)
	return ret_stat;

    /* If we got here, then it is a VMS file specification */
    ret_stat = 0;

    /* set the volume name */
    if (item_list[nodespec].length > 0) {
	*volume = item_list[nodespec].component;
	*vol_len = item_list[nodespec].length + item_list[devspec].length;
    }
    else {
	*volume = item_list[devspec].component;
	*vol_len = item_list[devspec].length;
    }

    *root = item_list[rootspec].component;
    *root_len = item_list[rootspec].length;

    *dir = item_list[dirspec].component;
    *dir_len = item_list[dirspec].length;

    /* Now fun with versions and EFS file specifications
     * The parser can not tell the difference when a "." is a version
     * delimiter or a part of the file specification.
     */
    if ((decc_efs_charset) && 
	(item_list[verspec].length > 0) &&
	(item_list[verspec].component[0] == '.')) {
	*name = item_list[namespec].component;
	*name_len = item_list[namespec].length + item_list[typespec].length;
	*ext = item_list[verspec].component;
	*ext_len = item_list[verspec].length;
	*version = NULL;
	*ver_len = 0;
    }
    else {
	*name = item_list[namespec].component;
	*name_len = item_list[namespec].length;
	*ext = item_list[typespec].component;
	*ext_len = item_list[typespec].length;
	*version = item_list[verspec].component;
	*ver_len = item_list[verspec].length;
    }
    return ret_stat;
}

/* Routine to determine if the file specification ends with .dir */
static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {

    /* e_len must be 4, and version must be <= 2 characters */
    if (e_len != 4 || vs_len > 2)
        return 0;

    /* If a version number is present, it needs to be one */
    if ((vs_len == 2) && (vs_spec[1] != '1'))
        return 0;

    /* Look for the DIR on the extension */
    if (vms_process_case_tolerant) {
        if ((toupper(e_spec[1]) == 'D') &&
            (toupper(e_spec[2]) == 'I') &&
            (toupper(e_spec[3]) == 'R')) {
            return 1;
        }
    } else {
        /* Directory extensions are supposed to be in upper case only */
        /* I would not be surprised if this rule can not be enforced */
        /* if and when someone fully debugs the case sensitive mode */
        if ((e_spec[1] == 'D') &&
            (e_spec[2] == 'I') &&
            (e_spec[3] == 'R')) {
            return 1;
        }
    }
    return 0;
}


/* my_maxidx
 * Routine to retrieve the maximum equivalence index for an input
 * logical name.  Some calls to this routine have no knowledge if
 * the variable is a logical or not.  So on error we return a max
 * index of zero.
 */
/*{{{int my_maxidx(const char *lnm) */
static int
my_maxidx(const char *lnm)
{
    int status;
    int midx;
    int attr = LNM$M_CASE_BLIND;
    struct dsc$descriptor lnmdsc;
    struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
                                {0, 0, 0, 0}};

    lnmdsc.dsc$w_length = strlen(lnm);
    lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
    lnmdsc.dsc$b_class = DSC$K_CLASS_S;
    lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */

    status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
    if ((status & 1) == 0)
       midx = 0;

    return (midx);
}
/*}}}*/

/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
int
Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
  struct dsc$descriptor_s **tabvec, unsigned long int flags)
{
    const char *cp1;
    char uplnm[LNM$C_NAMLENGTH+1], *cp2;
    unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
    unsigned long int retsts, attr = LNM$M_CASE_BLIND;
    int midx;
    unsigned char acmode;
    struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
                            tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
    struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
                                 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
                                 {0, 0, 0, 0}};
    $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
#if defined(PERL_IMPLICIT_CONTEXT)
    pTHX = NULL;
    if (PL_curinterp) {
      aTHX = PERL_GET_INTERP;
    } else {
      aTHX = NULL;
    }
#endif

    if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
      set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
    }
    for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
      *cp2 = _toupper(*cp1);
      if (cp1 - lnm > LNM$C_NAMLENGTH) {
        set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
        return 0;
      }
    }
    lnmdsc.dsc$w_length = cp1 - lnm;
    lnmdsc.dsc$a_pointer = uplnm;
    uplnm[lnmdsc.dsc$w_length] = '\0';
    secure = flags & PERL__TRNENV_SECURE;
    acmode = secure ? PSL$C_EXEC : PSL$C_USER;
    if (!tabvec || !*tabvec) tabvec = env_tables;

    for (curtab = 0; tabvec[curtab]; curtab++) {
      if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
        if (!ivenv && !secure) {
          char *eq;
          int i;
          if (!environ) {
            ivenv = 1; 
#if defined(PERL_IMPLICIT_CONTEXT)
            if (aTHX == NULL) {
                fprintf(stderr,
                    "Can't read CRTL environ\n");
            } else
#endif
                Perl_warn(aTHX_ "Can't read CRTL environ\n");
            continue;
          }
          retsts = SS$_NOLOGNAM;
          for (i = 0; environ[i]; i++) { 
            if ((eq = strchr(environ[i],'=')) && 
                lnmdsc.dsc$w_length == (eq - environ[i]) &&
                !strncmp(environ[i],uplnm,eq - environ[i])) {
              eq++;
              for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
              if (!eqvlen) continue;
              retsts = SS$_NORMAL;
              break;
            }
          }
          if (retsts != SS$_NOLOGNAM) break;
        }
      }
      else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
               !str$case_blind_compare(&tmpdsc,&clisym)) {
        if (!ivsym && !secure) {
          unsigned short int deflen = LNM$C_NAMLENGTH;
          struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
          /* dynamic dsc to accommodate possible long value */
          _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
          retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
          if (retsts & 1) { 
            if (eqvlen > MAX_DCL_SYMBOL) {
              set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
              eqvlen = MAX_DCL_SYMBOL;
	      /* Special hack--we might be called before the interpreter's */
	      /* fully initialized, in which case either thr or PL_curcop */
	      /* might be bogus. We have to check, since ckWARN needs them */
	      /* both to be valid if running threaded */
#if defined(PERL_IMPLICIT_CONTEXT)
              if (aTHX == NULL) {
                  fprintf(stderr,
                     "Value of CLI symbol \"%s\" too long",lnm);
              } else
#endif
		if (ckWARN(WARN_MISC)) {
		  Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
		}
            }
            strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
          }
          _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
          if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
          if (retsts == LIB$_NOSUCHSYM) continue;
          break;
        }
      }
      else if (!ivlnm) {
        if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
          midx = my_maxidx(lnm);
          for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
            lnmlst[1].bufadr = cp2;
            eqvlen = 0;
            retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
            if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
            if (retsts == SS$_NOLOGNAM) break;
            /* PPFs have a prefix */
            if (
#if INTSIZE == 4
                 *((int *)uplnm) == *((int *)"SYS$")                    &&
#endif
                 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
                 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
                   (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
                   (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
                   (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
              memmove(eqv,eqv+4,eqvlen-4);
              eqvlen -= 4;
            }
            cp2 += eqvlen;
            *cp2 = '\0';
          }
          if ((retsts == SS$_IVLOGNAM) ||
              (retsts == SS$_NOLOGNAM)) { continue; }
        }
        else {
          retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
          if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
          if (retsts == SS$_NOLOGNAM) continue;
          eqv[eqvlen] = '\0';
        }
        eqvlen = strlen(eqv);
        break;
      }
    }
    if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
    else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
             retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
             retsts == SS$_NOLOGNAM) {
      set_errno(EINVAL);  set_vaxc_errno(retsts);
    }
    else _ckvmssts_noperl(retsts);
    return 0;
}  /* end of vmstrnenv */
/*}}}*/

/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
/* Define as a function so we can access statics. */
int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
{
    int flags = 0;

#if defined(PERL_IMPLICIT_CONTEXT)
    if (aTHX != NULL)
#endif
#ifdef SECURE_INTERNAL_GETENV
        flags = (PL_curinterp ? PL_tainting : will_taint) ?
                 PERL__TRNENV_SECURE : 0;
#endif

    return vmstrnenv(lnm, eqv, idx, fildev, flags);
}
/*}}}*/

/* my_getenv
 * Note: Uses Perl temp to store result so char * can be returned to
 * caller; this pointer will be invalidated at next Perl statement
 * transition.
 * We define this as a function rather than a macro in terms of my_getenv_len()
 * so that it'll work when PL_curinterp is undefined (and we therefore can't
 * allocate SVs).
 */
/*{{{ char *my_getenv(const char *lnm, bool sys)*/
char *
Perl_my_getenv(pTHX_ const char *lnm, bool sys)
{
    const char *cp1;
    static char *__my_getenv_eqv = NULL;
    char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
    unsigned long int idx = 0;
    int success, secure, saverr, savvmserr;
    int midx, flags;
    SV *tmpsv;

    midx = my_maxidx(lnm) + 1;

    if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
      /* Set up a temporary buffer for the return value; Perl will
       * clean it up at the next statement transition */
      tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
      if (!tmpsv) return NULL;
      eqv = SvPVX(tmpsv);
    }
    else {
      /* Assume no interpreter ==> single thread */
      if (__my_getenv_eqv != NULL) {
        Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
      }
      else {
        Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
      }
      eqv = __my_getenv_eqv;  
    }

    for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
    if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
      int len;
      getcwd(eqv,LNM$C_NAMLENGTH);

      len = strlen(eqv);

      /* Get rid of "000000/ in rooted filespecs */
      if (len > 7) {
        char * zeros;
	zeros = strstr(eqv, "/000000/");
	if (zeros != NULL) {
	  int mlen;
	  mlen = len - (zeros - eqv) - 7;
	  memmove(zeros, &zeros[7], mlen);
	  len = len - 7;
	  eqv[len] = '\0';
	}
      }
      return eqv;
    }
    else {
      /* Impose security constraints only if tainting */
      if (sys) {
        /* Impose security constraints only if tainting */
        secure = PL_curinterp ? PL_tainting : will_taint;
        saverr = errno;  savvmserr = vaxc$errno;
      }
      else {
        secure = 0;
      }

      flags = 
#ifdef SECURE_INTERNAL_GETENV
              secure ? PERL__TRNENV_SECURE : 0
#else
              0
#endif
      ;

      /* For the getenv interface we combine all the equivalence names
       * of a search list logical into one value to acquire a maximum
       * value length of 255*128 (assuming %ENV is using logicals).
       */
      flags |= PERL__TRNENV_JOIN_SEARCHLIST;

      /* If the name contains a semicolon-delimited index, parse it
       * off and make sure we only retrieve the equivalence name for 
       * that index.  */
      if ((cp2 = strchr(lnm,';')) != NULL) {
        strcpy(uplnm,lnm);
        uplnm[cp2-lnm] = '\0';
        idx = strtoul(cp2+1,NULL,0);
        lnm = uplnm;
        flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
      }

      success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);

      /* Discard NOLOGNAM on internal calls since we're often looking
       * for an optional name, and this "error" often shows up as the
       * (bogus) exit status for a die() call later on.  */
      if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
      return success ? eqv : NULL;
    }

}  /* end of my_getenv() */
/*}}}*/


/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
char *
Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
{
    const char *cp1;
    char *buf, *cp2;
    unsigned long idx = 0;
    int midx, flags;
    static char *__my_getenv_len_eqv = NULL;
    int secure, saverr, savvmserr;
    SV *tmpsv;
    
    midx = my_maxidx(lnm) + 1;

    if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
      /* Set up a temporary buffer for the return value; Perl will
       * clean it up at the next statement transition */
      tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
      if (!tmpsv) return NULL;
      buf = SvPVX(tmpsv);
    }
    else {
      /* Assume no interpreter ==> single thread */
      if (__my_getenv_len_eqv != NULL) {
        Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
      }
      else {
        Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
      }
      buf = __my_getenv_len_eqv;  
    }

    for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
    if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
    char * zeros;

      getcwd(buf,LNM$C_NAMLENGTH);
      *len = strlen(buf);

      /* Get rid of "000000/ in rooted filespecs */
      if (*len > 7) {
      zeros = strstr(buf, "/000000/");
      if (zeros != NULL) {
	int mlen;
	mlen = *len - (zeros - buf) - 7;
	memmove(zeros, &zeros[7], mlen);
	*len = *len - 7;
	buf[*len] = '\0';
	}
      }
      return buf;
    }
    else {
      if (sys) {
        /* Impose security constraints only if tainting */
        secure = PL_curinterp ? PL_tainting : will_taint;
        saverr = errno;  savvmserr = vaxc$errno;
      }
      else {
        secure = 0;
      }

      flags = 
#ifdef SECURE_INTERNAL_GETENV
              secure ? PERL__TRNENV_SECURE : 0
#else
              0
#endif
      ;

      flags |= PERL__TRNENV_JOIN_SEARCHLIST;

      if ((cp2 = strchr(lnm,';')) != NULL) {
        strcpy(buf,lnm);
        buf[cp2-lnm] = '\0';
        idx = strtoul(cp2+1,NULL,0);
        lnm = buf;
        flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
      }

      *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);

      /* Get rid of "000000/ in rooted filespecs */
      if (*len > 7) {
      char * zeros;
	zeros = strstr(buf, "/000000/");
	if (zeros != NULL) {
	  int mlen;
	  mlen = *len - (zeros - buf) - 7;
	  memmove(zeros, &zeros[7], mlen);
	  *len = *len - 7;
	  buf[*len] = '\0';
	}
      }

      /* Discard NOLOGNAM on internal calls since we're often looking
       * for an optional name, and this "error" often shows up as the
       * (bogus) exit status for a die() call later on.  */
      if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
      return *len ? buf : NULL;
    }

}  /* end of my_getenv_len() */
/*}}}*/

static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);

static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }

/*{{{ void prime_env_iter() */
void
prime_env_iter(void)
/* Fill the %ENV associative array with all logical names we can
 * find, in preparation for iterating over it.
 */
{
  static int primed = 0;
  HV *seenhv = NULL, *envhv;
  SV *sv = NULL;
  char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
  unsigned short int chan;
#ifndef CLI$M_TRUSTED
#  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
#endif
  unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
  unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
  long int i;
  bool have_sym = FALSE, have_lnm = FALSE;
  struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
  $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
  $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
  $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
  $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam); 
#if defined(PERL_IMPLICIT_CONTEXT)
  pTHX;
#endif
#if defined(USE_ITHREADS)
  static perl_mutex primenv_mutex;
  MUTEX_INIT(&primenv_mutex);
#endif

#if defined(PERL_IMPLICIT_CONTEXT)
    /* We jump through these hoops because we can be called at */
    /* platform-specific initialization time, which is before anything is */
    /* set up--we can't even do a plain dTHX since that relies on the */
    /* interpreter structure to be initialized */
    if (PL_curinterp) {
      aTHX = PERL_GET_INTERP;
    } else {
      /* we never get here because the NULL pointer will cause the */
      /* several of the routines called by this routine to access violate */

      /* This routine is only called by hv.c/hv_iterinit which has a */
      /* context, so the real fix may be to pass it through instead of */
      /* the hoops above */
      aTHX = NULL;
    }
#endif

  if (primed || !PL_envgv) return;
  MUTEX_LOCK(&primenv_mutex);
  if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
  envhv = GvHVn(PL_envgv);
  /* Perform a dummy fetch as an lval to insure that the hash table is
   * set up.  Otherwise, the hv_store() will turn into a nullop. */
  (void) hv_fetch(envhv,"DEFAULT",7,TRUE);

  for (i = 0; env_tables[i]; i++) {
     if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
         !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
     if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
  }
  if (have_sym || have_lnm) {
    long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
    _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
    _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
    _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
  }

  for (i--; i >= 0; i--) {
    if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
      char *start;
      int j;
      for (j = 0; environ[j]; j++) { 
        if (!(start = strchr(environ[j],'='))) {
          if (ckWARN(WARN_INTERNAL)) 
            Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
        }
        else {
          start++;
          sv = newSVpv(start,0);
          SvTAINTED_on(sv);
          (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
        }
      }
      continue;
    }
    else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
             !str$case_blind_compare(&tmpdsc,&clisym)) {
      strcpy(cmd,"Show Symbol/Global *");
      cmddsc.dsc$w_length = 20;
      if (env_tables[i]->dsc$w_length == 12 &&
          (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
          !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
      flags = defflags | CLI$M_NOLOGNAM;
    }
    else {
      strcpy(cmd,"Show Logical *");
      if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
        strcat(cmd," /Table=");
        strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
        cmddsc.dsc$w_length = strlen(cmd);
      }
      else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
      flags = defflags | CLI$M_NOCLISYM;
    }
    
    /* Create a new subprocess to execute each command, to exclude the
     * remote possibility that someone could subvert a mbx or file used
     * to write multiple commands to a single subprocess.
     */
    do {
      retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
                         0,&riseandshine,0,0,&clidsc,&clitabdsc);
      flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
      defflags &= ~CLI$M_TRUSTED;
    } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
    _ckvmssts(retsts);
    if (!buf) Newx(buf,mbxbufsiz + 1,char);
    if (seenhv) SvREFCNT_dec(seenhv);
    seenhv = newHV();
    while (1) {
      char *cp1, *cp2, *key;
      unsigned long int sts, iosb[2], retlen, keylen;
      register U32 hash;

      sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
      if (sts & 1) sts = iosb[0] & 0xffff;
      if (sts == SS$_ENDOFFILE) {
        int wakect = 0;
        while (substs == 0) { sys$hiber(); wakect++;}
        if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
        _ckvmssts(substs);
        break;
      }
      _ckvmssts(sts);
      retlen = iosb[0] >> 16;      
      if (!retlen) continue;  /* blank line */
      buf[retlen] = '\0';
      if (iosb[1] != subpid) {
        if (iosb[1]) {
          Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
        }
        continue;
      }
      if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
        Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);

      for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
      if (*cp1 == '(' || /* Logical name table name */
          *cp1 == '='    /* Next eqv of searchlist  */) continue;
      if (*cp1 == '"') cp1++;
      for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
      key = cp1;  keylen = cp2 - cp1;
      if (keylen && hv_exists(seenhv,key,keylen)) continue;
      while (*cp2 && *cp2 != '=') cp2++;
      while (*cp2 && *cp2 == '=') cp2++;
      while (*cp2 && *cp2 == ' ') cp2++;
      if (*cp2 == '"') {  /* String translation; may embed "" */
        for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
        cp2++;  cp1--; /* Skip "" surrounding translation */
      }
      else {  /* Numeric translation */
        for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
        cp1--;  /* stop on last non-space char */
      }
      if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
        Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
        continue;
      }
      PERL_HASH(hash,key,keylen);

      if (cp1 == cp2 && *cp2 == '.') {
        /* A single dot usually means an unprintable character, such as a null
         * to indicate a zero-length value.  Get the actual value to make sure.
         */
        char lnm[LNM$C_NAMLENGTH+1];
        char eqv[MAX_DCL_SYMBOL+1];
        int trnlen;
        strncpy(lnm, key, keylen);
        trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
        sv = newSVpvn(eqv, strlen(eqv));
      }
      else {
        sv = newSVpvn(cp2,cp1 - cp2 + 1);
      }

      SvTAINTED_on(sv);
      hv_store(envhv,key,keylen,sv,hash);
      hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
    }
    if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
      /* get the PPFs for this process, not the subprocess */
      const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
      char eqv[LNM$C_NAMLENGTH+1];
      int trnlen, i;
      for (i = 0; ppfs[i]; i++) {
        trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
        sv = newSVpv(eqv,trnlen);
        SvTAINTED_on(sv);
        hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
      }
    }
  }
  primed = 1;
  if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
  if (buf) Safefree(buf);
  if (seenhv) SvREFCNT_dec(seenhv);
  MUTEX_UNLOCK(&primenv_mutex);
  return;

}  /* end of prime_env_iter */
/*}}}*/


/*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
/* Define or delete an element in the same "environment" as
 * vmstrnenv().  If an element is to be deleted, it's removed from
 * the first place it's found.  If it's to be set, it's set in the
 * place designated by the first element of the table vector.
 * Like setenv() returns 0 for success, non-zero on error.
 */
int
Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
{
    const char *cp1;
    char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
    unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
    int nseg = 0, j;
    unsigned long int retsts, usermode = PSL$C_USER;
    struct itmlst_3 *ile, *ilist;
    struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
                            eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
                            tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
    $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
    $DESCRIPTOR(local,"_LOCAL");

    if (!lnm) {
        set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
        return SS$_IVLOGNAM;
    }

    for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
      *cp2 = _toupper(*cp1);
      if (cp1 - lnm > LNM$C_NAMLENGTH) {
        set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
        return SS$_IVLOGNAM;
      }
    }
    lnmdsc.dsc$w_length = cp1 - lnm;
    if (!tabvec || !*tabvec) tabvec = env_tables;

    if (!eqv) {  /* we're deleting n element */
      for (curtab = 0; tabvec[curtab]; curtab++) {
        if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
        int i;
          for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
            if ((cp1 = strchr(environ[i],'=')) && 
                lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
                !strncmp(environ[i],lnm,cp1 - environ[i])) {
#ifdef HAS_SETENV
              return setenv(lnm,"",1) ? vaxc$errno : 0;
            }
          }
          ivenv = 1; retsts = SS$_NOLOGNAM;
#else
              if (ckWARN(WARN_INTERNAL))
                Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
              ivenv = 1; retsts = SS$_NOSUCHPGM;
              break;
            }
          }
#endif
        }
        else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
                 !str$case_blind_compare(&tmpdsc,&clisym)) {
          unsigned int symtype;
          if (tabvec[curtab]->dsc$w_length == 12 &&
              (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
              !str$case_blind_compare(&tmpdsc,&local)) 
            symtype = LIB$K_CLI_LOCAL_SYM;
          else symtype = LIB$K_CLI_GLOBAL_SYM;
          retsts = lib$delete_symbol(&lnmdsc,&symtype);
          if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
          if (retsts == LIB$_NOSUCHSYM) continue;
          break;
        }
        else if (!ivlnm) {
          retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
          if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
          if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
          retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
          if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
        }
      }
    }
    else {  /* we're defining a value */
      if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
#ifdef HAS_SETENV
        return setenv(lnm,eqv,1) ? vaxc$errno : 0;
#else
        if (ckWARN(WARN_INTERNAL))
          Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
        retsts = SS$_NOSUCHPGM;
#endif
      }
      else {
        eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
        eqvdsc.dsc$w_length  = strlen(eqv);
        if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
            !str$case_blind_compare(&tmpdsc,&clisym)) {
          unsigned int symtype;
          if (tabvec[0]->dsc$w_length == 12 &&
              (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
               !str$case_blind_compare(&tmpdsc,&local)) 
            symtype = LIB$K_CLI_LOCAL_SYM;
          else symtype = LIB$K_CLI_GLOBAL_SYM;
          retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
        }
        else {
          if (!*eqv) eqvdsc.dsc$w_length = 1;
	  if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {

            nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
            if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
	      Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
                          lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
              eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
              nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
	    }

            Newx(ilist,nseg+1,struct itmlst_3);
            ile = ilist;
            if (!ile) {
	      set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
              return SS$_INSFMEM;
	    }
            memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));

            for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
              ile->itmcode = LNM$_STRING;
              ile->bufadr = c;
              if ((j+1) == nseg) {
                ile->buflen = strlen(c);
                /* in case we are truncating one that's too long */
                if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
              }
              else {
                ile->buflen = LNM$C_NAMLENGTH;
              }
            }

            retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
            Safefree (ilist);
	  }
          else {
            retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
	  }
        }
      }
    }
    if (!(retsts & 1)) {
      switch (retsts) {
        case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
        case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
          set_errno(EVMSERR); break;
        case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM: 
        case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
          set_errno(EINVAL); break;
        case SS$_NOPRIV:
          set_errno(EACCES); break;
        default:
          _ckvmssts(retsts);
          set_errno(EVMSERR);
       }
       set_vaxc_errno(retsts);
       return (int) retsts || 44; /* retsts should never be 0, but just in case */
    }
    else {
      /* We reset error values on success because Perl does an hv_fetch()
       * before each hv_store(), and if the thing we're setting didn't
       * previously exist, we've got a leftover error message.  (Of course,
       * this fails in the face of
       *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
       * in that the error reported in $! isn't spurious, 
       * but it's right more often than not.)
       */
      set_errno(0); set_vaxc_errno(retsts);
      return 0;
    }

}  /* end of vmssetenv() */
/*}}}*/

/*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
/* This has to be a function since there's a prototype for it in proto.h */
void
Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
{
    if (lnm && *lnm) {
      int len = strlen(lnm);
      if  (len == 7) {
        char uplnm[8];
        int i;
        for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
        if (!strcmp(uplnm,"DEFAULT")) {
          if (eqv && *eqv) my_chdir(eqv);
          return;
        }
    } 
#ifndef RTL_USES_UTC
    if (len == 6 || len == 2) {
      char uplnm[7];
      int i;
      for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
      uplnm[len] = '\0';
      if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
      if (!strcmp(uplnm,"TZ")) tz_updated = 1;
    }
#endif
  }
  (void) vmssetenv(lnm,eqv,NULL);
}
/*}}}*/

/*{{{static void vmssetuserlnm(char *name, char *eqv); */
/*  vmssetuserlnm
 *  sets a user-mode logical in the process logical name table
 *  used for redirection of sys$error
 *
 *  Fix-me: The pTHX is not needed for this routine, however doio.c
 *          is calling it with one instead of using a macro.
 *          A macro needs to be added to vmsish.h and doio.c updated to use it.
 *
 */
void
Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
{
    $DESCRIPTOR(d_tab, "LNM$PROCESS");
    struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
    unsigned long int iss, attr = LNM$M_CONFINE;
    unsigned char acmode = PSL$C_USER;
    struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
                                 {0, 0, 0, 0}};
    d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
    d_name.dsc$w_length = strlen(name);

    lnmlst[0].buflen = strlen(eqv);
    lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */

    iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
    if (!(iss&1)) lib$signal(iss);
}
/*}}}*/


/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
/* my_crypt - VMS password hashing
 * my_crypt() provides an interface compatible with the Unix crypt()
 * C library function, and uses sys$hash_password() to perform VMS
 * password hashing.  The quadword hashed password value is returned
 * as a NUL-terminated 8 character string.  my_crypt() does not change
 * the case of its string arguments; in order to match the behavior
 * of LOGINOUT et al., alphabetic characters in both arguments must
 *  be upcased by the caller.
 *
 * - fix me to call ACM services when available
 */
char *
Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
{
#   ifndef UAI$C_PREFERRED_ALGORITHM
#     define UAI$C_PREFERRED_ALGORITHM 127
#   endif
    unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
    unsigned short int salt = 0;
    unsigned long int sts;
    struct const_dsc {
        unsigned short int dsc$w_length;
        unsigned char      dsc$b_type;
        unsigned char      dsc$b_class;
        const char *       dsc$a_pointer;
    }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
       txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
    struct itmlst_3 uailst[3] = {
        { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
        { sizeof salt, UAI$_SALT,    &salt, 0},
        { 0,           0,            NULL,  NULL}};
    static char hash[9];

    usrdsc.dsc$w_length = strlen(usrname);
    usrdsc.dsc$a_pointer = usrname;
    if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
      switch (sts) {
        case SS$_NOGRPPRV: case SS$_NOSYSPRV:
          set_errno(EACCES);
          break;
        case RMS$_RNF:
          set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
          break;
        default:
          set_errno(EVMSERR);
      }
      set_vaxc_errno(sts);
      if (sts != RMS$_RNF) return NULL;
    }

    txtdsc.dsc$w_length = strlen(textpasswd);
    txtdsc.dsc$a_pointer = textpasswd;
    if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
      set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
    }

    return (char *) hash;

}  /* end of my_crypt() */
/*}}}*/


static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);

/* fixup barenames that are directories for internal use.
 * There have been problems with the consistent handling of UNIX
 * style directory names when routines are presented with a name that
 * has no directory delimiters at all.  So this routine will eventually
 * fix the issue.
 */
static char * fixup_bare_dirnames(const char * name)
{
  if (decc_disable_to_vms_logname_translation) {
/* fix me */
  }
  return NULL;
}

/* 8.3, remove() is now broken on symbolic links */
static int rms_erase(const char * vmsname);


/* mp_do_kill_file
 * A little hack to get around a bug in some implementation of remove()
 * that do not know how to delete a directory
 *
 * Delete any file to which user has control access, regardless of whether
 * delete access is explicitly allowed.
 * Limitations: User must have write access to parent directory.
 *              Does not block signals or ASTs; if interrupted in midstream
 *              may leave file with an altered ACL.
 * HANDLE WITH CARE!
 */
/*{{{int mp_do_kill_file(const char *name, int dirflag)*/
static int
mp_do_kill_file(pTHX_ const char *name, int dirflag)
{
    char *vmsname;
    char *rslt;
    unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
    unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
    struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
    struct myacedef {
      unsigned char myace$b_length;
      unsigned char myace$b_type;
      unsigned short int myace$w_flags;
      unsigned long int myace$l_access;
      unsigned long int myace$l_ident;
    } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
                 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
      oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
     struct itmlst_3
       findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
                     {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
       addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
       dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
       lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
       ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};

    /* Expand the input spec using RMS, since the CRTL remove() and
     * system services won't do this by themselves, so we may miss
     * a file "hiding" behind a logical name or search list. */
    vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
    if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);

    rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
    if (rslt == NULL) {
        PerlMem_free(vmsname);
	return -1;
      }

    /* Erase the file */
    rmsts = rms_erase(vmsname);

    /* Did it succeed */
    if ($VMS_STATUS_SUCCESS(rmsts)) {
	PerlMem_free(vmsname);
	return 0;
      }

    /* If not, can changing protections help? */
    if (rmsts != RMS$_PRV) {
      set_vaxc_errno(rmsts);
      PerlMem_free(vmsname);
      return -1;
    }

    /* No, so we get our own UIC to use as a rights identifier,
     * and the insert an ACE at the head of the ACL which allows us
     * to delete the file.
     */
    _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
    fildsc.dsc$w_length = strlen(vmsname);
    fildsc.dsc$a_pointer = vmsname;
    cxt = 0;
    newace.myace$l_ident = oldace.myace$l_ident;
    rmsts = -1;
    if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
      switch (aclsts) {
        case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
          set_errno(ENOENT); break;
        case RMS$_DIR:
          set_errno(ENOTDIR); break;
        case RMS$_DEV:
          set_errno(ENODEV); break;
        case RMS$_SYN: case SS$_INVFILFOROP:
          set_errno(EINVAL); break;
        case RMS$_PRV:
          set_errno(EACCES); break;
        default:
          _ckvmssts_noperl(aclsts);
      }
      set_vaxc_errno(aclsts);
      PerlMem_free(vmsname);
      return -1;
    }
    /* Grab any existing ACEs with this identifier in case we fail */
    aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
    if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
                    || fndsts == SS$_NOMOREACE ) {
      /* Add the new ACE . . . */
      if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
        goto yourroom;

      rmsts = rms_erase(vmsname);
      if ($VMS_STATUS_SUCCESS(rmsts)) {
	rmsts = 0;
	}
	else {
	rmsts = -1;
        /* We blew it - dir with files in it, no write priv for
         * parent directory, etc.  Put things back the way they were. */
        if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
          goto yourroom;
        if (fndsts & 1) {
          addlst[0].bufadr = &oldace;
          if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
            goto yourroom;
        }
      }
    }

    yourroom:
    fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
    /* We just deleted it, so of course it's not there.  Some versions of
     * VMS seem to return success on the unlock operation anyhow (after all
     * the unlock is successful), but others don't.
     */
    if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
    if (aclsts & 1) aclsts = fndsts;
    if (!(aclsts & 1)) {
      set_errno(EVMSERR);
      set_vaxc_errno(aclsts);
    }

    PerlMem_free(vmsname);
    return rmsts;

}  /* end of kill_file() */
/*}}}*/


/*{{{int do_rmdir(char *name)*/
int
Perl_do_rmdir(pTHX_ const char *name)
{
    char * dirfile;
    int retval;
    Stat_t st;

    /* lstat returns a VMS fileified specification of the name */
    /* that is looked up, and also lets verifies that this is a directory */

    retval = flex_lstat(name, &st);
    if (retval != 0) {
        char * ret_spec;

        /* Due to a historical feature, flex_stat/lstat can not see some */
        /* Unix format file names that the rest of the CRTL can see */
        /* Fixing that feature will cause some perl tests to fail */
        /* So try this one more time. */

        retval = lstat(name, &st.crtl_stat);
        if (retval != 0)
            return -1;

        /* force it to a file spec for the kill file to work. */
        ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
        if (ret_spec == NULL) {
            errno = EIO;
            return -1;
        }
    }

    if (!S_ISDIR(st.st_mode)) {
	errno = ENOTDIR;
	retval = -1;
    }
    else {
        dirfile = st.st_devnam;

        /* It may be possible for flex_stat to find a file and vmsify() to */
        /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
        /* with that case, so fail it */
        if (dirfile[0] == 0) {
            errno = EIO;
            return -1;
        }

	retval = mp_do_kill_file(aTHX_ dirfile, 1);
    }

    return retval;

}  /* end of do_rmdir */
/*}}}*/

/* kill_file
 * Delete any file to which user has control access, regardless of whether
 * delete access is explicitly allowed.
 * Limitations: User must have write access to parent directory.
 *              Does not block signals or ASTs; if interrupted in midstream
 *              may leave file with an altered ACL.
 * HANDLE WITH CARE!
 */
/*{{{int kill_file(char *name)*/
int
Perl_kill_file(pTHX_ const char *name)
{
    char * vmsfile;
    Stat_t st;
    int rmsts;

    /* Convert the filename to VMS format and see if it is a directory */
    /* flex_lstat returns a vmsified file specification */
    rmsts = flex_lstat(name, &st);
    if (rmsts != 0) {

        /* Due to a historical feature, flex_stat/lstat can not see some */
        /* Unix format file names that the rest of the CRTL can see when */
        /* ODS-2 file specifications are in use. */
        /* Fixing that feature will cause some perl tests to fail */
        /* [.lib.ExtUtils.t]Manifest.t is one of them */
        st.st_mode = 0;
        vmsfile = (char *) name; /* cast ok */

    } else {
        vmsfile = st.st_devnam;
        if (vmsfile[0] == 0) {
            /* It may be possible for flex_stat to find a file and vmsify() */
            /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
            /* deal with that case, so fail it */
            errno = EIO;
            return -1;
        }
    }

    /* Remove() is allowed to delete directories, according to the X/Open
     * specifications.
     * This may need special handling to work with the ACL hacks.
     */
    if (S_ISDIR(st.st_mode)) {
        rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
        return rmsts;
    }

    rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);

    /* Need to delete all versions ? */
    if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
        int i = 0;

        /* Just use lstat() here as do not need st_dev */
        /* and we know that the file is in VMS format or that */
        /* because of a historical bug, flex_stat can not see the file */
        while (lstat(vmsfile, (stat_t *)&st) == 0) {
            rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
            if (rmsts != 0)
                break;
            i++;

            /* Make sure that we do not loop forever */
            if (i > 32767) {
                errno = EIO;
                rmsts = -1;
                break;
            }
        }
    }

    return rmsts;

}  /* end of kill_file() */
/*}}}*/


/*{{{int my_mkdir(char *,Mode_t)*/
int
Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
{
  STRLEN dirlen = strlen(dir);

  /* zero length string sometimes gives ACCVIO */
  if (dirlen == 0) return -1;

  /* CRTL mkdir() doesn't tolerate trailing /, since that implies
   * null file name/type.  However, it's commonplace under Unix,
   * so we'll allow it for a gain in portability.
   */
  if (dir[dirlen-1] == '/') {
    char *newdir = savepvn(dir,dirlen-1);
    int ret = mkdir(newdir,mode);
    Safefree(newdir);
    return ret;
  }
  else return mkdir(dir,mode);
}  /* end of my_mkdir */
/*}}}*/

/*{{{int my_chdir(char *)*/
int
Perl_my_chdir(pTHX_ const char *dir)
{
  STRLEN dirlen = strlen(dir);

  /* zero length string sometimes gives ACCVIO */
  if (dirlen == 0) return -1;
  const char *dir1;

  /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
   * This does not work if DECC$EFS_CHARSET is active.  Hack it here
   * so that existing scripts do not need to be changed.
   */
  dir1 = dir;
  while ((dirlen > 0) && (*dir1 == ' ')) {
    dir1++;
    dirlen--;
  }

  /* some versions of CRTL chdir() doesn't tolerate trailing /, since
   * that implies
   * null file name/type.  However, it's commonplace under Unix,
   * so we'll allow it for a gain in portability.
   *
   *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
   */
  if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
      char *newdir;
      int ret;
      newdir = PerlMem_malloc(dirlen);
      if (newdir ==NULL)
          _ckvmssts_noperl(SS$_INSFMEM);
      strncpy(newdir, dir1, dirlen-1);
      newdir[dirlen-1] = '\0';
      ret = chdir(newdir);
      PerlMem_free(newdir);
      return ret;
  }
  else return chdir(dir1);
}  /* end of my_chdir */
/*}}}*/


/*{{{int my_chmod(char *, mode_t)*/
int
Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
{
  Stat_t st;
  int ret = -1;
  char * changefile;
  STRLEN speclen = strlen(file_spec);

  /* zero length string sometimes gives ACCVIO */
  if (speclen == 0) return -1;

  /* some versions of CRTL chmod() doesn't tolerate trailing /, since
   * that implies null file name/type.  However, it's commonplace under Unix,
   * so we'll allow it for a gain in portability.
   *
   * Tests are showing that chmod() on VMS 8.3 is only accepting directories
   * in VMS file.dir notation.
   */
  changefile = (char *) file_spec; /* cast ok */
  ret = flex_lstat(file_spec, &st);
  if (ret != 0) {

        /* Due to a historical feature, flex_stat/lstat can not see some */
        /* Unix format file names that the rest of the CRTL can see when */
        /* ODS-2 file specifications are in use. */
        /* Fixing that feature will cause some perl tests to fail */
        /* [.lib.ExtUtils.t]Manifest.t is one of them */
        st.st_mode = 0;

  } else {
      /* It may be possible to get here with nothing in st_devname */
      /* chmod still may work though */
      if (st.st_devnam[0] != 0) {
          changefile = st.st_devnam;
      }
  }
  ret = chmod(changefile, mode);
  return ret;
}  /* end of my_chmod */
/*}}}*/


/*{{{FILE *my_tmpfile()*/
FILE *
my_tmpfile(void)
{
  FILE *fp;
  char *cp;

  if ((fp = tmpfile())) return fp;

  cp = PerlMem_malloc(L_tmpnam+24);
  if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);

  if (decc_filename_unix_only == 0)
    strcpy(cp,"Sys$Scratch:");
  else
    strcpy(cp,"/tmp/");
  tmpnam(cp+strlen(cp));
  strcat(cp,".Perltmp");
  fp = fopen(cp,"w+","fop=dlt");
  PerlMem_free(cp);
  return fp;
}
/*}}}*/


#ifndef HOMEGROWN_POSIX_SIGNALS
/*
 * The C RTL's sigaction fails to check for invalid signal numbers so we 
 * help it out a bit.  The docs are correct, but the actual routine doesn't
 * do what the docs say it will.
 */
/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
int
Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act, 
                   struct sigaction* oact)
{
  if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
	SETERRNO(EINVAL, SS$_INVARG);
	return -1;
  }
  return sigaction(sig, act, oact);
}
/*}}}*/
#endif

#ifdef KILL_BY_SIGPRC
#include <errnodef.h>

/* We implement our own kill() using the undocumented system service
   sys$sigprc for one of two reasons:

   1.) If the kill() in an older CRTL uses sys$forcex, causing the
   target process to do a sys$exit, which usually can't be handled 
   gracefully...certainly not by Perl and the %SIG{} mechanism.

   2.) If the kill() in the CRTL can't be called from a signal
   handler without disappearing into the ether, i.e., the signal
   it purportedly sends is never trapped. Still true as of VMS 7.3.

   sys$sigprc has the same parameters as sys$forcex, but throws an exception
   in the target process rather than calling sys$exit.

   Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
   on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
   provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
   with condition codes C$_SIG0+nsig*8, catching the exception on the 
   target process and resignaling with appropriate arguments.

   But we don't have that VMS 7.0+ exception handler, so if you
   Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.

   Also note that SIGTERM is listed in the docs as being "unimplemented",
   yet always seems to be signaled with a VMS condition code of 4 (and
   correctly handled for that code).  So we hardwire it in.

   Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
   number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
   than signalling with an unrecognized (and unhandled by CRTL) code.
*/

#define _MY_SIG_MAX 28

static unsigned int
Perl_sig_to_vmscondition_int(int sig)
{
    static unsigned int sig_code[_MY_SIG_MAX+1] = 
    {
        0,                  /*  0 ZERO     */
        SS$_HANGUP,         /*  1 SIGHUP   */
        SS$_CONTROLC,       /*  2 SIGINT   */
        SS$_CONTROLY,       /*  3 SIGQUIT  */
        SS$_RADRMOD,        /*  4 SIGILL   */
        SS$_BREAK,          /*  5 SIGTRAP  */
        SS$_OPCCUS,         /*  6 SIGABRT  */
        SS$_COMPAT,         /*  7 SIGEMT   */
#ifdef __VAX                      
        SS$_FLTOVF,         /*  8 SIGFPE VAX */
#else                             
        SS$_HPARITH,        /*  8 SIGFPE AXP */
#endif                            
        SS$_ABORT,          /*  9 SIGKILL  */
        SS$_ACCVIO,         /* 10 SIGBUS   */
        SS$_ACCVIO,         /* 11 SIGSEGV  */
        SS$_BADPARAM,       /* 12 SIGSYS   */
        SS$_NOMBX,          /* 13 SIGPIPE  */
        SS$_ASTFLT,         /* 14 SIGALRM  */
        4,                  /* 15 SIGTERM  */
        0,                  /* 16 SIGUSR1  */
        0,                  /* 17 SIGUSR2  */
        0,                  /* 18 */
        0,                  /* 19 */
        0,                  /* 20 SIGCHLD  */
        0,                  /* 21 SIGCONT  */
        0,                  /* 22 SIGSTOP  */
        0,                  /* 23 SIGTSTP  */
        0,                  /* 24 SIGTTIN  */
        0,                  /* 25 SIGTTOU  */
        0,                  /* 26 */
        0,                  /* 27 */
        0                   /* 28 SIGWINCH  */
    };

#if __VMS_VER >= 60200000
    static int initted = 0;
    if (!initted) {
        initted = 1;
        sig_code[16] = C$_SIGUSR1;
        sig_code[17] = C$_SIGUSR2;
#if __CRTL_VER >= 70000000
        sig_code[20] = C$_SIGCHLD;
#endif
#if __CRTL_VER >= 70300000
        sig_code[28] = C$_SIGWINCH;
#endif
    }
#endif

    if (sig < _SIG_MIN) return 0;
    if (sig > _MY_SIG_MAX) return 0;
    return sig_code[sig];
}

unsigned int
Perl_sig_to_vmscondition(int sig)
{
#ifdef SS$_DEBUG
    if (vms_debug_on_exception != 0)
	lib$signal(SS$_DEBUG);
#endif
    return Perl_sig_to_vmscondition_int(sig);
}


int
Perl_my_kill(int pid, int sig)
{
    int iss;
    unsigned int code;
#define sys$sigprc SYS$SIGPRC
    int sys$sigprc(unsigned int *pidadr,
                     struct dsc$descriptor_s *prcname,
                     unsigned int code);

     /* sig 0 means validate the PID */
    /*------------------------------*/
    if (sig == 0) {
	const unsigned long int jpicode = JPI$_PID;
	pid_t ret_pid;
	int status;
        status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
	if ($VMS_STATUS_SUCCESS(status))
	   return 0;
	switch (status) {
        case SS$_NOSUCHNODE:
        case SS$_UNREACHABLE:
	case SS$_NONEXPR:
	   errno = ESRCH;
	   break;
	case SS$_NOPRIV:
	   errno = EPERM;
	   break;
	default:
	   errno = EVMSERR;
	}
	vaxc$errno=status;
	return -1;
    }

    code = Perl_sig_to_vmscondition_int(sig);

    if (!code) {
	SETERRNO(EINVAL, SS$_BADPARAM);
        return -1;
    }

    /* Fixme: Per official UNIX specification: If pid = 0, or negative then
     * signals are to be sent to multiple processes.
     *  pid = 0 - all processes in group except ones that the system exempts
     *  pid = -1 - all processes except ones that the system exempts
     *  pid = -n - all processes in group (abs(n)) except ... 
     * For now, just report as not supported.
     */

    if (pid <= 0) {
	SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
        return -1;
    }

    iss = sys$sigprc((unsigned int *)&pid,0,code);
    if (iss&1) return 0;

    switch (iss) {
      case SS$_NOPRIV:
        set_errno(EPERM);  break;
      case SS$_NONEXPR:  
      case SS$_NOSUCHNODE:
      case SS$_UNREACHABLE:
        set_errno(ESRCH);  break;
      case SS$_INSFMEM:
        set_errno(ENOMEM); break;
      default:
        _ckvmssts_noperl(iss);
        set_errno(EVMSERR);
    } 
    set_vaxc_errno(iss);
 
    return -1;
}
#endif

/* Routine to convert a VMS status code to a UNIX status code.
** More tricky than it appears because of conflicting conventions with
** existing code.
**
** VMS status codes are a bit mask, with the least significant bit set for
** success.
**
** Special UNIX status of EVMSERR indicates that no translation is currently
** available, and programs should check the VMS status code.
**
** Programs compiled with _POSIX_EXIT have a special encoding that requires
** decoding.
*/

#ifndef C_FACILITY_NO
#define C_FACILITY_NO 0x350000
#endif
#ifndef DCL_IVVERB
#define DCL_IVVERB 0x38090
#endif

int Perl_vms_status_to_unix(int vms_status, int child_flag)
{
int facility;
int fac_sp;
int msg_no;
int msg_status;
int unix_status;

  /* Assume the best or the worst */
  if (vms_status & STS$M_SUCCESS)
    unix_status = 0;
  else
    unix_status = EVMSERR;

  msg_status = vms_status & ~STS$M_CONTROL;

  facility = vms_status & STS$M_FAC_NO;
  fac_sp = vms_status & STS$M_FAC_SP;
  msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);

  if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
    switch(msg_no) {
    case SS$_NORMAL:
	unix_status = 0;
	break;
    case SS$_ACCVIO:
	unix_status = EFAULT;
	break;
    case SS$_DEVOFFLINE:
	unix_status = EBUSY;
	break;
    case SS$_CLEARED:
	unix_status = ENOTCONN;
	break;
    case SS$_IVCHAN:
    case SS$_IVLOGNAM:
    case SS$_BADPARAM:
    case SS$_IVLOGTAB:
    case SS$_NOLOGNAM:
    case SS$_NOLOGTAB:
    case SS$_INVFILFOROP:
    case SS$_INVARG:
    case SS$_NOSUCHID:
    case SS$_IVIDENT:
	unix_status = EINVAL;
	break;
    case SS$_UNSUPPORTED:
	unix_status = ENOTSUP;
	break;
    case SS$_FILACCERR:
    case SS$_NOGRPPRV:
    case SS$_NOSYSPRV:
	unix_status = EACCES;
	break;
    case SS$_DEVICEFULL:
	unix_status = ENOSPC;
	break;
    case SS$_NOSUCHDEV:
	unix_status = ENODEV;
	break;
    case SS$_NOSUCHFILE:
    case SS$_NOSUCHOBJECT:
	unix_status = ENOENT;
	break;
    case SS$_ABORT:				    /* Fatal case */
    case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
    case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
	unix_status = EINTR;
	break;
    case SS$_BUFFEROVF:
	unix_status = E2BIG;
	break;
    case SS$_INSFMEM:
	unix_status = ENOMEM;
	break;
    case SS$_NOPRIV:
	unix_status = EPERM;
	break;
    case SS$_NOSUCHNODE:
    case SS$_UNREACHABLE:
	unix_status = ESRCH;
	break;
    case SS$_NONEXPR:
	unix_status = ECHILD;
	break;
    default:
	if ((facility == 0) && (msg_no < 8)) {
	  /* These are not real VMS status codes so assume that they are
          ** already UNIX status codes
	  */
	  unix_status = msg_no;
	  break;
	}
    }
  }
  else {
    /* Translate a POSIX exit code to a UNIX exit code */
    if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
	unix_status = (msg_no & 0x07F8) >> 3;
    }
    else {

	 /* Documented traditional behavior for handling VMS child exits */
	/*--------------------------------------------------------------*/
	if (child_flag != 0) {

	     /* Success / Informational return 0 */
	    /*----------------------------------*/
	    if (msg_no & STS$K_SUCCESS)
		return 0;

	     /* Warning returns 1 */
	    /*-------------------*/
	    if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
	    	return 1;

	     /* Everything else pass through the severity bits */
	    /*------------------------------------------------*/
	    return (msg_no & STS$M_SEVERITY);
	}

	 /* Normal VMS status to ERRNO mapping attempt */
	/*--------------------------------------------*/
	switch(msg_status) {
	/* case RMS$_EOF: */ /* End of File */
	case RMS$_FNF:	/* File Not Found */
	case RMS$_DNF:	/* Dir Not Found */
		unix_status = ENOENT;
		break;
	case RMS$_RNF:	/* Record Not Found */
		unix_status = ESRCH;
		break;
	case RMS$_DIR:
		unix_status = ENOTDIR;
		break;
	case RMS$_DEV:
		unix_status = ENODEV;
		break;
	case RMS$_IFI:
	case RMS$_FAC:
	case RMS$_ISI:
		unix_status = EBADF;
		break;
	case RMS$_FEX:
		unix_status = EEXIST;
		break;
	case RMS$_SYN:
	case RMS$_FNM:
	case LIB$_INVSTRDES:
	case LIB$_INVARG:
	case LIB$_NOSUCHSYM:
	case LIB$_INVSYMNAM:
	case DCL_IVVERB:
		unix_status = EINVAL;
		break;
	case CLI$_BUFOVF:
	case RMS$_RTB:
	case CLI$_TKNOVF:
	case CLI$_RSLOVF:
		unix_status = E2BIG;
		break;
	case RMS$_PRV:	/* No privilege */
	case RMS$_ACC:	/* ACP file access failed */
	case RMS$_WLK:	/* Device write locked */
		unix_status = EACCES;
		break;
	case RMS$_MKD:  /* Failed to mark for delete */
		unix_status = EPERM;
		break;
	/* case RMS$_NMF: */  /* No more files */
	}
    }
  }

  return unix_status;
} 

/* Try to guess at what VMS error status should go with a UNIX errno
 * value.  This is hard to do as there could be many possible VMS
 * error statuses that caused the errno value to be set.
 */

int Perl_unix_status_to_vms(int unix_status)
{
int test_unix_status;

     /* Trivial cases first */
    /*---------------------*/
    if (unix_status == EVMSERR)
	return vaxc$errno;

     /* Is vaxc$errno sane? */
    /*---------------------*/
    test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
    if (test_unix_status == unix_status)
	return vaxc$errno;

     /* If way out of range, must be VMS code already */
    /*-----------------------------------------------*/
    if (unix_status > EVMSERR)
	return unix_status;

     /* If out of range, punt */
    /*-----------------------*/
    if (unix_status > __ERRNO_MAX)
	return SS$_ABORT;


     /* Ok, now we have to do it the hard way. */
    /*----------------------------------------*/
    switch(unix_status) {
    case 0:	return SS$_NORMAL;
    case EPERM: return SS$_NOPRIV;
    case ENOENT: return SS$_NOSUCHOBJECT;
    case ESRCH: return SS$_UNREACHABLE;
    case EINTR: return SS$_ABORT;
    /* case EIO: */
    /* case ENXIO:  */
    case E2BIG: return SS$_BUFFEROVF;
    /* case ENOEXEC */
    case EBADF: return RMS$_IFI;
    case ECHILD: return SS$_NONEXPR;
    /* case EAGAIN */
    case ENOMEM: return SS$_INSFMEM;
    case EACCES: return SS$_FILACCERR;
    case EFAULT: return SS$_ACCVIO;
    /* case ENOTBLK */
    case EBUSY: return SS$_DEVOFFLINE;
    case EEXIST: return RMS$_FEX;
    /* case EXDEV */
    case ENODEV: return SS$_NOSUCHDEV;
    case ENOTDIR: return RMS$_DIR;
    /* case EISDIR */
    case EINVAL: return SS$_INVARG;
    /* case ENFILE */
    /* case EMFILE */
    /* case ENOTTY */
    /* case ETXTBSY */
    /* case EFBIG */
    case ENOSPC: return SS$_DEVICEFULL;
    case ESPIPE: return LIB$_INVARG;
    /* case EROFS: */
    /* case EMLINK: */
    /* case EPIPE: */
    /* case EDOM */
    case ERANGE: return LIB$_INVARG;
    /* case EWOULDBLOCK */
    /* case EINPROGRESS */
    /* case EALREADY */
    /* case ENOTSOCK */
    /* case EDESTADDRREQ */
    /* case EMSGSIZE */
    /* case EPROTOTYPE */
    /* case ENOPROTOOPT */
    /* case EPROTONOSUPPORT */
    /* case ESOCKTNOSUPPORT */
    /* case EOPNOTSUPP */
    /* case EPFNOSUPPORT */
    /* case EAFNOSUPPORT */
    /* case EADDRINUSE */
    /* case EADDRNOTAVAIL */
    /* case ENETDOWN */
    /* case ENETUNREACH */
    /* case ENETRESET */
    /* case ECONNABORTED */
    /* case ECONNRESET */
    /* case ENOBUFS */
    /* case EISCONN */
    case ENOTCONN: return SS$_CLEARED;
    /* case ESHUTDOWN */
    /* case ETOOMANYREFS */
    /* case ETIMEDOUT */
    /* case ECONNREFUSED */
    /* case ELOOP */
    /* case ENAMETOOLONG */
    /* case EHOSTDOWN */
    /* case EHOSTUNREACH */
    /* case ENOTEMPTY */
    /* case EPROCLIM */
    /* case EUSERS  */
    /* case EDQUOT  */
    /* case ENOMSG  */
    /* case EIDRM */
    /* case EALIGN */
    /* case ESTALE */
    /* case EREMOTE */
    /* case ENOLCK */
    /* case ENOSYS */
    /* case EFTYPE */
    /* case ECANCELED */
    /* case EFAIL */
    /* case EINPROG */
    case ENOTSUP:
	return SS$_UNSUPPORTED;
    /* case EDEADLK */
    /* case ENWAIT */
    /* case EILSEQ */
    /* case EBADCAT */
    /* case EBADMSG */
    /* case EABANDONED */
    default:
	return SS$_ABORT; /* punt */
    }
} 


/* default piping mailbox size */
#ifdef __VAX
#  define PERL_BUFSIZ        512
#else
#  define PERL_BUFSIZ        8192
#endif


static void
create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
{
  unsigned long int mbxbufsiz;
  static unsigned long int syssize = 0;
  unsigned long int dviitm = DVI$_DEVNAM;
  char csize[LNM$C_NAMLENGTH+1];
  int sts;

  if (!syssize) {
    unsigned long syiitm = SYI$_MAXBUF;
    /*
     * Get the SYSGEN parameter MAXBUF
     *
     * If the logical 'PERL_MBX_SIZE' is defined
     * use the value of the logical instead of PERL_BUFSIZ, but 
     * keep the size between 128 and MAXBUF.
     *
     */
    _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
  }

  if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
      mbxbufsiz = atoi(csize);
  } else {
      mbxbufsiz = PERL_BUFSIZ;
  }
  if (mbxbufsiz < 128) mbxbufsiz = 128;
  if (mbxbufsiz > syssize) mbxbufsiz = syssize;

  _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));

  sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
  _ckvmssts_noperl(sts);
  namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';

}  /* end of create_mbx() */


/*{{{  my_popen and my_pclose*/

typedef struct _iosb           IOSB;
typedef struct _iosb*         pIOSB;
typedef struct _pipe           Pipe;
typedef struct _pipe*         pPipe;
typedef struct pipe_details    Info;
typedef struct pipe_details*  pInfo;
typedef struct _srqp            RQE;
typedef struct _srqp*          pRQE;
typedef struct _tochildbuf      CBuf;
typedef struct _tochildbuf*    pCBuf;

struct _iosb {
    unsigned short status;
    unsigned short count;
    unsigned long  dvispec;
};

#pragma member_alignment save
#pragma nomember_alignment quadword
struct _srqp {          /* VMS self-relative queue entry */
    unsigned long qptr[2];
};
#pragma member_alignment restore
static RQE  RQE_ZERO = {0,0};

struct _tochildbuf {
    RQE             q;
    int             eof;
    unsigned short  size;
    char            *buf;
};

struct _pipe {
    RQE            free;
    RQE            wait;
    int            fd_out;
    unsigned short chan_in;
    unsigned short chan_out;
    char          *buf;
    unsigned int   bufsize;
    IOSB           iosb;
    IOSB           iosb2;
    int           *pipe_done;
    int            retry;
    int            type;
    int            shut_on_empty;
    int            need_wake;
    pPipe         *home;
    pInfo          info;
    pCBuf          curr;
    pCBuf          curr2;
#if defined(PERL_IMPLICIT_CONTEXT)
    void	    *thx;	    /* Either a thread or an interpreter */
                                    /* pointer, depending on how we're built */
#endif
};


struct pipe_details
{
    pInfo           next;
    PerlIO *fp;  /* file pointer to pipe mailbox */
    int useFILE; /* using stdio, not perlio */
    int pid;   /* PID of subprocess */
    int mode;  /* == 'r' if pipe open for reading */
    int done;  /* subprocess has completed */
    int waiting; /* waiting for completion/closure */
    int             closing;        /* my_pclose is closing this pipe */
    unsigned long   completion;     /* termination status of subprocess */
    pPipe           in;             /* pipe in to sub */
    pPipe           out;            /* pipe out of sub */
    pPipe           err;            /* pipe of sub's sys$error */
    int             in_done;        /* true when in pipe finished */
    int             out_done;
    int             err_done;
    unsigned short  xchan;	    /* channel to debug xterm */
    unsigned short  xchan_valid;    /* channel is assigned */
};

struct exit_control_block
{
    struct exit_control_block *flink;
    unsigned long int	(*exit_routine)();
    unsigned long int arg_count;
    unsigned long int *status_address;
    unsigned long int exit_status;
}; 

typedef struct _closed_pipes    Xpipe;
typedef struct _closed_pipes*  pXpipe;

struct _closed_pipes {
    int             pid;            /* PID of subprocess */
    unsigned long   completion;     /* termination status of subprocess */
};
#define NKEEPCLOSED 50
static Xpipe closed_list[NKEEPCLOSED];
static int   closed_index = 0;
static int   closed_num = 0;

#define RETRY_DELAY     "0 ::0.20"
#define MAX_RETRY              50

static int pipe_ef = 0;          /* first call to safe_popen inits these*/
static unsigned long mypid;
static unsigned long delaytime[2];

static pInfo open_pipes = NULL;
static $DESCRIPTOR(nl_desc, "NL:");

#define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */



static unsigned long int
pipe_exit_routine()
{
    pInfo info;
    unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
    int sts, did_stuff, j;

   /* 
    * Flush any pending i/o, but since we are in process run-down, be
    * careful about referencing PerlIO structures that may already have
    * been deallocated.  We may not even have an interpreter anymore.
    */
    info = open_pipes;
    while (info) {
        if (info->fp) {
#if defined(PERL_IMPLICIT_CONTEXT)
           /* We need to use the Perl context of the thread that created */
           /* the pipe. */
           pTHX;
           if (info->err)
               aTHX = info->err->thx;
           else if (info->out)
               aTHX = info->out->thx;
           else if (info->in)
               aTHX = info->in->thx;
#endif
           if (!info->useFILE
#if defined(USE_ITHREADS)
             && my_perl
#endif
#ifdef USE_PERLIO
             && PL_perlio_fd_refcnt 
#endif
              )
               PerlIO_flush(info->fp);
           else 
               fflush((FILE *)info->fp);
        }
        info = info->next;
    }

    /* 
     next we try sending an EOF...ignore if doesn't work, make sure we
     don't hang
    */
    did_stuff = 0;
    info = open_pipes;

    while (info) {
      _ckvmssts_noperl(sys$setast(0));
      if (info->in && !info->in->shut_on_empty) {
        _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
                                 0, 0, 0, 0, 0, 0));
        info->waiting = 1;
        did_stuff = 1;
      }
      _ckvmssts_noperl(sys$setast(1));
      info = info->next;
    }

    /* wait for EOF to have effect, up to ~ 30 sec [default] */

    for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
        int nwait = 0;

        info = open_pipes;
        while (info) {
          _ckvmssts_noperl(sys$setast(0));
          if (info->waiting && info->done) 
                info->waiting = 0;
          nwait += info->waiting;
          _ckvmssts_noperl(sys$setast(1));
          info = info->next;
        }
        if (!nwait) break;
        sleep(1);  
    }

    did_stuff = 0;
    info = open_pipes;
    while (info) {
      _ckvmssts_noperl(sys$setast(0));
      if (!info->done) { /* Tap them gently on the shoulder . . .*/
        sts = sys$forcex(&info->pid,0,&abort);
        if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts); 
        did_stuff = 1;
      }
      _ckvmssts_noperl(sys$setast(1));
      info = info->next;
    }

    /* again, wait for effect */

    for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
        int nwait = 0;

        info = open_pipes;
        while (info) {
          _ckvmssts_noperl(sys$setast(0));
          if (info->waiting && info->done) 
                info->waiting = 0;
          nwait += info->waiting;
          _ckvmssts_noperl(sys$setast(1));
          info = info->next;
        }
        if (!nwait) break;
        sleep(1);  
    }

    info = open_pipes;
    while (info) {
      _ckvmssts_noperl(sys$setast(0));
      if (!info->done) {  /* We tried to be nice . . . */
        sts = sys$delprc(&info->pid,0);
        if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts); 
        info->done = 1;  /* sys$delprc is as done as we're going to get. */
      }
      _ckvmssts_noperl(sys$setast(1));
      info = info->next;
    }

    while(open_pipes) {

#if defined(PERL_IMPLICIT_CONTEXT)
      /* We need to use the Perl context of the thread that created */
      /* the pipe. */
      pTHX;
      if (open_pipes->err)
          aTHX = open_pipes->err->thx;
      else if (open_pipes->out)
          aTHX = open_pipes->out->thx;
      else if (open_pipes->in)
          aTHX = open_pipes->in->thx;
#endif
      if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
      else if (!(sts & 1)) retsts = sts;
    }
    return retsts;
}

static struct exit_control_block pipe_exitblock = 
       {(struct exit_control_block *) 0,
        pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};

static void pipe_mbxtofd_ast(pPipe p);
static void pipe_tochild1_ast(pPipe p);
static void pipe_tochild2_ast(pPipe p);

static void
popen_completion_ast(pInfo info)
{
  pInfo i = open_pipes;
  int iss;

  info->completion &= 0x0FFFFFFF; /* strip off "control" field */
  closed_list[closed_index].pid = info->pid;
  closed_list[closed_index].completion = info->completion;
  closed_index++;
  if (closed_index == NKEEPCLOSED) 
    closed_index = 0;
  closed_num++;

  while (i) {
    if (i == info) break;
    i = i->next;
  }
  if (!i) return;       /* unlinked, probably freed too */

  info->done = TRUE;

/*
    Writing to subprocess ...
            if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe

            chan_out may be waiting for "done" flag, or hung waiting
            for i/o completion to child...cancel the i/o.  This will
            put it into "snarf mode" (done but no EOF yet) that discards
            input.

    Output from subprocess (stdout, stderr) needs to be flushed and
    shut down.   We try sending an EOF, but if the mbx is full the pipe
    routine should still catch the "shut_on_empty" flag, telling it to
    use immediate-style reads so that "mbx empty" -> EOF.


*/
  if (info->in && !info->in_done) {               /* only for mode=w */
        if (info->in->shut_on_empty && info->in->need_wake) {
            info->in->need_wake = FALSE;
            _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
        } else {
            _ckvmssts_noperl(sys$cancel(info->in->chan_out));
        }
  }

  if (info->out && !info->out_done) {             /* were we also piping output? */
      info->out->shut_on_empty = TRUE;
      iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
      if (iss == SS$_MBFULL) iss = SS$_NORMAL;
      _ckvmssts_noperl(iss);
  }

  if (info->err && !info->err_done) {        /* we were piping stderr */
        info->err->shut_on_empty = TRUE;
        iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
        if (iss == SS$_MBFULL) iss = SS$_NORMAL;
        _ckvmssts_noperl(iss);
  }
  _ckvmssts_noperl(sys$setef(pipe_ef));

}

static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
static void vms_execfree(struct dsc$descriptor_s *vmscmd);
static void pipe_infromchild_ast(pPipe p);

/*
    I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
    inside an AST routine without worrying about reentrancy and which Perl
    memory allocator is being used.

    We read data and queue up the buffers, then spit them out one at a
    time to the output mailbox when the output mailbox is ready for one.

*/
#define INITIAL_TOCHILDQUEUE  2

static pPipe
pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
{
    pPipe p;
    pCBuf b;
    char mbx1[64], mbx2[64];
    struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
                                      DSC$K_CLASS_S, mbx1},
                            d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
                                      DSC$K_CLASS_S, mbx2};
    unsigned int dviitm = DVI$_DEVBUFSIZ;
    int j, n;

    n = sizeof(Pipe);
    _ckvmssts_noperl(lib$get_vm(&n, &p));

    create_mbx(&p->chan_in , &d_mbx1);
    create_mbx(&p->chan_out, &d_mbx2);
    _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));

    p->buf           = 0;
    p->shut_on_empty = FALSE;
    p->need_wake     = FALSE;
    p->type          = 0;
    p->retry         = 0;
    p->iosb.status   = SS$_NORMAL;
    p->iosb2.status  = SS$_NORMAL;
    p->free          = RQE_ZERO;
    p->wait          = RQE_ZERO;
    p->curr          = 0;
    p->curr2         = 0;
    p->info          = 0;
#ifdef PERL_IMPLICIT_CONTEXT
    p->thx	     = aTHX;
#endif

    n = sizeof(CBuf) + p->bufsize;

    for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
        _ckvmssts_noperl(lib$get_vm(&n, &b));
        b->buf = (char *) b + sizeof(CBuf);
        _ckvmssts_noperl(lib$insqhi(b, &p->free));
    }

    pipe_tochild2_ast(p);
    pipe_tochild1_ast(p);
    strcpy(wmbx, mbx1);
    strcpy(rmbx, mbx2);
    return p;
}

/*  reads the MBX Perl is writing, and queues */

static void
pipe_tochild1_ast(pPipe p)
{
    pCBuf b = p->curr;
    int iss = p->iosb.status;
    int eof = (iss == SS$_ENDOFFILE);
    int sts;
#ifdef PERL_IMPLICIT_CONTEXT
    pTHX = p->thx;
#endif

    if (p->retry) {
        if (eof) {
            p->shut_on_empty = TRUE;
            b->eof     = TRUE;
            _ckvmssts_noperl(sys$dassgn(p->chan_in));
        } else  {
            _ckvmssts_noperl(iss);
        }

        b->eof  = eof;
        b->size = p->iosb.count;
        _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
        if (p->need_wake) {
            p->need_wake = FALSE;
            _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
        }
    } else {
        p->retry = 1;   /* initial call */
    }

    if (eof) {                  /* flush the free queue, return when done */
        int n = sizeof(CBuf) + p->bufsize;
        while (1) {
            iss = lib$remqti(&p->free, &b);
            if (iss == LIB$_QUEWASEMP) return;
            _ckvmssts_noperl(iss);
            _ckvmssts_noperl(lib$free_vm(&n, &b));
        }
    }

    iss = lib$remqti(&p->free, &b);
    if (iss == LIB$_QUEWASEMP) {
        int n = sizeof(CBuf) + p->bufsize;
        _ckvmssts_noperl(lib$get_vm(&n, &b));
        b->buf = (char *) b + sizeof(CBuf);
    } else {
       _ckvmssts_noperl(iss);
    }

    p->curr = b;
    iss = sys$qio(0,p->chan_in,
             IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
             &p->iosb,
             pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
    if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
    _ckvmssts_noperl(iss);
}


/* writes queued buffers to output, waits for each to complete before
   doing the next */

static void
pipe_tochild2_ast(pPipe p)
{
    pCBuf b = p->curr2;
    int iss = p->iosb2.status;
    int n = sizeof(CBuf) + p->bufsize;
    int done = (p->info && p->info->done) ||
              iss == SS$_CANCEL || iss == SS$_ABORT;
#if defined(PERL_IMPLICIT_CONTEXT)
    pTHX = p->thx;
#endif

    do {
        if (p->type) {         /* type=1 has old buffer, dispose */
            if (p->shut_on_empty) {
                _ckvmssts_noperl(lib$free_vm(&n, &b));
            } else {
                _ckvmssts_noperl(lib$insqhi(b, &p->free));
            }
            p->type = 0;
        }

        iss = lib$remqti(&p->wait, &b);
        if (iss == LIB$_QUEWASEMP) {
            if (p->shut_on_empty) {
                if (done) {
                    _ckvmssts_noperl(sys$dassgn(p->chan_out));
                    *p->pipe_done = TRUE;
                    _ckvmssts_noperl(sys$setef(pipe_ef));
                } else {
                    _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
                        &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
                }
                return;
            }
            p->need_wake = TRUE;
            return;
        }
        _ckvmssts_noperl(iss);
        p->type = 1;
    } while (done);


    p->curr2 = b;
    if (b->eof) {
        _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
            &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
    } else {
        _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
            &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
    }

    return;

}


static pPipe
pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
{
    pPipe p;
    char mbx1[64], mbx2[64];
    struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
                                      DSC$K_CLASS_S, mbx1},
                            d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
                                      DSC$K_CLASS_S, mbx2};
    unsigned int dviitm = DVI$_DEVBUFSIZ;

    int n = sizeof(Pipe);
    _ckvmssts_noperl(lib$get_vm(&n, &p));
    create_mbx(&p->chan_in , &d_mbx1);
    create_mbx(&p->chan_out, &d_mbx2);

    _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
    n = p->bufsize * sizeof(char);
    _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
    p->shut_on_empty = FALSE;
    p->info   = 0;
    p->type   = 0;
    p->iosb.status = SS$_NORMAL;
#if defined(PERL_IMPLICIT_CONTEXT)
    p->thx = aTHX;
#endif
    pipe_infromchild_ast(p);

    strcpy(wmbx, mbx1);
    strcpy(rmbx, mbx2);
    return p;
}

static void
pipe_infromchild_ast(pPipe p)
{
    int iss = p->iosb.status;
    int eof = (iss == SS$_ENDOFFILE);
    int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
    int kideof = (eof && (p->iosb.dvispec == p->info->pid));
#if defined(PERL_IMPLICIT_CONTEXT)
    pTHX = p->thx;
#endif

    if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
        _ckvmssts_noperl(sys$dassgn(p->chan_out));
        p->chan_out = 0;
    }

    /* read completed:
            input shutdown if EOF from self (done or shut_on_empty)
            output shutdown if closing flag set (my_pclose)
            send data/eof from child or eof from self
            otherwise, re-read (snarf of data from child)
    */

    if (p->type == 1) {
        p->type = 0;
        if (myeof && p->chan_in) {                  /* input shutdown */
            _ckvmssts_noperl(sys$dassgn(p->chan_in));
            p->chan_in = 0;
        }

        if (p->chan_out) {
            if (myeof || kideof) {      /* pass EOF to parent */
                _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
                                         pipe_infromchild_ast, p,
                                         0, 0, 0, 0, 0, 0));
                return;
            } else if (eof) {       /* eat EOF --- fall through to read*/

            } else {                /* transmit data */
                _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
                                         pipe_infromchild_ast,p,
                                         p->buf, p->iosb.count, 0, 0, 0, 0));
                return;
            }
        }
    }

    /*  everything shut? flag as done */

    if (!p->chan_in && !p->chan_out) {
        *p->pipe_done = TRUE;
        _ckvmssts_noperl(sys$setef(pipe_ef));
        return;
    }

    /* write completed (or read, if snarfing from child)
            if still have input active,
               queue read...immediate mode if shut_on_empty so we get EOF if empty
            otherwise,
               check if Perl reading, generate EOFs as needed
    */

    if (p->type == 0) {
        p->type = 1;
        if (p->chan_in) {
            iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
                          pipe_infromchild_ast,p,
                          p->buf, p->bufsize, 0, 0, 0, 0);
            if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
            _ckvmssts_noperl(iss);
        } else {           /* send EOFs for extra reads */
            p->iosb.status = SS$_ENDOFFILE;
            p->iosb.dvispec = 0;
            _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
                                     0, 0, 0,
                                     pipe_infromchild_ast, p, 0, 0, 0, 0));
        }
    }
}

static pPipe
pipe_mbxtofd_setup(pTHX_ int fd, char *out)
{
    pPipe p;
    char mbx[64];
    unsigned long dviitm = DVI$_DEVBUFSIZ;
    struct stat s;
    struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
                                      DSC$K_CLASS_S, mbx};
    int n = sizeof(Pipe);

    /* things like terminals and mbx's don't need this filter */
    if (fd && fstat(fd,&s) == 0) {
        unsigned long devchar;
	char device[65];
	unsigned short dev_len;
	struct dsc$descriptor_s d_dev;
	char * cptr;
	struct item_list_3 items[3];
	int status;
	unsigned short dvi_iosb[4];

	cptr = getname(fd, out, 1);
	if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
	d_dev.dsc$a_pointer = out;
	d_dev.dsc$w_length = strlen(out);
	d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
	d_dev.dsc$b_class = DSC$K_CLASS_S;

	items[0].len = 4;
	items[0].code = DVI$_DEVCHAR;
	items[0].bufadr = &devchar;
	items[0].retadr = NULL;
	items[1].len = 64;
	items[1].code = DVI$_FULLDEVNAM;
	items[1].bufadr = device;
	items[1].retadr = &dev_len;
	items[2].len = 0;
	items[2].code = 0;

	status = sys$getdviw
	        (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
	_ckvmssts_noperl(status);
	if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
	    device[dev_len] = 0;

	    if (!(devchar & DEV$M_DIR)) {
		strcpy(out, device);
		return 0;
	    }
	}
    }

    _ckvmssts_noperl(lib$get_vm(&n, &p));
    p->fd_out = dup(fd);
    create_mbx(&p->chan_in, &d_mbx);
    _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
    n = (p->bufsize+1) * sizeof(char);
    _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
    p->shut_on_empty = FALSE;
    p->retry = 0;
    p->info  = 0;
    strcpy(out, mbx);

    _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
                             pipe_mbxtofd_ast, p,
                             p->buf, p->bufsize, 0, 0, 0, 0));

    return p;
}

static void
pipe_mbxtofd_ast(pPipe p)
{
    int iss = p->iosb.status;
    int done = p->info->done;
    int iss2;
    int eof = (iss == SS$_ENDOFFILE);
    int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
    int err = !(iss&1) && !eof;
#if defined(PERL_IMPLICIT_CONTEXT)
    pTHX = p->thx;
#endif

    if (done && myeof) {               /* end piping */
        close(p->fd_out);
        sys$dassgn(p->chan_in);
        *p->pipe_done = TRUE;
        _ckvmssts_noperl(sys$setef(pipe_ef));
        return;
    }

    if (!err && !eof) {             /* good data to send to file */
        p->buf[p->iosb.count] = '\n';
        iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
        if (iss2 < 0) {
            p->retry++;
            if (p->retry < MAX_RETRY) {
                _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
                return;
            }
        }
        p->retry = 0;
    } else if (err) {
        _ckvmssts_noperl(iss);
    }


    iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
          pipe_mbxtofd_ast, p,
          p->buf, p->bufsize, 0, 0, 0, 0);
    if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
    _ckvmssts_noperl(iss);
}


typedef struct _pipeloc     PLOC;
typedef struct _pipeloc*   pPLOC;

struct _pipeloc {
    pPLOC   next;
    char    dir[NAM$C_MAXRSS+1];
};
static pPLOC  head_PLOC = 0;

void
free_pipelocs(pTHX_ void *head)
{
    pPLOC p, pnext;
    pPLOC *pHead = (pPLOC *)head;

    p = *pHead;
    while (p) {
        pnext = p->next;
        PerlMem_free(p);
        p = pnext;
    }
    *pHead = 0;
}

static void
store_pipelocs(pTHX)
{
    int    i;
    pPLOC  p;
    AV    *av = 0;
    SV    *dirsv;
    char  *dir, *x;
    char  *unixdir;
    char  temp[NAM$C_MAXRSS+1];
    STRLEN n_a;

    if (head_PLOC)  
        free_pipelocs(aTHX_ &head_PLOC);

/*  the . directory from @INC comes last */

    p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
    if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
    p->next = head_PLOC;
    head_PLOC = p;
    strcpy(p->dir,"./");

/*  get the directory from $^X */

    unixdir = PerlMem_malloc(VMS_MAXRSS);
    if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);

#ifdef PERL_IMPLICIT_CONTEXT
    if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
#else
    if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
#endif
        strcpy(temp, PL_origargv[0]);
        x = strrchr(temp,']');
	if (x == NULL) {
	x = strrchr(temp,'>');
	  if (x == NULL) {
	    /* It could be a UNIX path */
	    x = strrchr(temp,'/');
	  }
	}
	if (x)
	  x[1] = '\0';
	else {
	  /* Got a bare name, so use default directory */
	  temp[0] = '.';
	  temp[1] = '\0';
	}

        if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
            p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
	    if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
            p->next = head_PLOC;
            head_PLOC = p;
            strncpy(p->dir,unixdir,sizeof(p->dir)-1);
            p->dir[NAM$C_MAXRSS] = '\0';
	}
    }

/*  reverse order of @INC entries, skip "." since entered above */

#ifdef PERL_IMPLICIT_CONTEXT
    if (aTHX)
#endif
    if (PL_incgv) av = GvAVn(PL_incgv);

    for (i = 0; av && i <= AvFILL(av); i++) {
        dirsv = *av_fetch(av,i,TRUE);

        if (SvROK(dirsv)) continue;
        dir = SvPVx(dirsv,n_a);
        if (strcmp(dir,".") == 0) continue;
        if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
            continue;

        p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
        p->next = head_PLOC;
        head_PLOC = p;
        strncpy(p->dir,unixdir,sizeof(p->dir)-1);
        p->dir[NAM$C_MAXRSS] = '\0';
    }

/* most likely spot (ARCHLIB) put first in the list */

#ifdef ARCHLIB_EXP
    if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
        p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
	if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
        p->next = head_PLOC;
        head_PLOC = p;
        strncpy(p->dir,unixdir,sizeof(p->dir)-1);
        p->dir[NAM$C_MAXRSS] = '\0';
    }
#endif
    PerlMem_free(unixdir);
}

static I32
Perl_cando_by_name_int
   (pTHX_ I32 bit, bool effective, const char *fname, int opts);
#if !defined(PERL_IMPLICIT_CONTEXT)
#define cando_by_name_int		Perl_cando_by_name_int
#else
#define cando_by_name_int(a,b,c,d)	Perl_cando_by_name_int(aTHX_ a,b,c,d)
#endif

static char *
find_vmspipe(pTHX)
{
    static int   vmspipe_file_status = 0;
    static char  vmspipe_file[NAM$C_MAXRSS+1];

    /* already found? Check and use ... need read+execute permission */

    if (vmspipe_file_status == 1) {
        if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
         && cando_by_name_int
	   (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
            return vmspipe_file;
        }
        vmspipe_file_status = 0;
    }

    /* scan through stored @INC, $^X */

    if (vmspipe_file_status == 0) {
        char file[NAM$C_MAXRSS+1];
        pPLOC  p = head_PLOC;

        while (p) {
	    char * exp_res;
	    int dirlen;
            strcpy(file, p->dir);
	    dirlen = strlen(file);
            strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
            file[NAM$C_MAXRSS] = '\0';
            p = p->next;

            exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
            if (!exp_res) continue;

            if (cando_by_name_int
		(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
             && cando_by_name_int
		   (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
                vmspipe_file_status = 1;
                return vmspipe_file;
            }
        }
        vmspipe_file_status = -1;   /* failed, use tempfiles */
    }

    return 0;
}

static FILE *
vmspipe_tempfile(pTHX)
{
    char file[NAM$C_MAXRSS+1];
    FILE *fp;
    static int index = 0;
    Stat_t s0, s1;
    int cmp_result;

    /* create a tempfile */

    /* we can't go from   W, shr=get to  R, shr=get without
       an intermediate vulnerable state, so don't bother trying...

       and lib$spawn doesn't shr=put, so have to close the write

       So... match up the creation date/time and the FID to
       make sure we're dealing with the same file

    */

    index++;
    if (!decc_filename_unix_only) {
      sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
      fp = fopen(file,"w");
      if (!fp) {
        sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
        fp = fopen(file,"w");
        if (!fp) {
            sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
            fp = fopen(file,"w");
	}
      }
     }
     else {
      sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
      fp = fopen(file,"w");
      if (!fp) {
	sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
	fp = fopen(file,"w");
	if (!fp) {
	  sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
	  fp = fopen(file,"w");
	}
      }
    }
    if (!fp) return 0;  /* we're hosed */

    fprintf(fp,"$! 'f$verify(0)'\n");
    fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
    fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
    fprintf(fp,"$ perl_define = \"define/nolog\"\n");
    fprintf(fp,"$ perl_on     = \"set noon\"\n");
    fprintf(fp,"$ perl_exit   = \"exit\"\n");
    fprintf(fp,"$ perl_del    = \"delete\"\n");
    fprintf(fp,"$ pif         = \"if\"\n");
    fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
    fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
    fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
    fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
    fprintf(fp,"$!  --- build command line to get max possible length\n");
    fprintf(fp,"$c=perl_popen_cmd0\n"); 
    fprintf(fp,"$c=c+perl_popen_cmd1\n"); 
    fprintf(fp,"$c=c+perl_popen_cmd2\n"); 
    fprintf(fp,"$x=perl_popen_cmd3\n"); 
    fprintf(fp,"$c=c+x\n"); 
    fprintf(fp,"$ perl_on\n");
    fprintf(fp,"$ 'c'\n");
    fprintf(fp,"$ perl_status = $STATUS\n");
    fprintf(fp,"$ perl_del  'perl_cfile'\n");
    fprintf(fp,"$ perl_exit 'perl_status'\n");
    fsync(fileno(fp));

    fgetname(fp, file, 1);
    fstat(fileno(fp), &s0.crtl_stat);
    fclose(fp);

    if (decc_filename_unix_only)
	int_tounixspec(file, file, NULL);
    fp = fopen(file,"r","shr=get");
    if (!fp) return 0;
    fstat(fileno(fp), &s1.crtl_stat);

    cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
    if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
        fclose(fp);
        return 0;
    }

    return fp;
}


static int vms_is_syscommand_xterm(void)
{
    const static struct dsc$descriptor_s syscommand_dsc = 
      { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };

    const static struct dsc$descriptor_s decwdisplay_dsc = 
      { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };

    struct item_list_3 items[2];
    unsigned short dvi_iosb[4];
    unsigned long devchar;
    unsigned long devclass;
    int status;

    /* Very simple check to guess if sys$command is a decterm? */
    /* First see if the DECW$DISPLAY: device exists */
    items[0].len = 4;
    items[0].code = DVI$_DEVCHAR;
    items[0].bufadr = &devchar;
    items[0].retadr = NULL;
    items[1].len = 0;
    items[1].code = 0;

    status = sys$getdviw
	(NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);

    if ($VMS_STATUS_SUCCESS(status)) {
        status = dvi_iosb[0];
    }

    if (!$VMS_STATUS_SUCCESS(status)) {
        SETERRNO(EVMSERR, status);
	return -1;
    }

    /* If it does, then for now assume that we are on a workstation */
    /* Now verify that SYS$COMMAND is a terminal */
    /* for creating the debugger DECTerm */

    items[0].len = 4;
    items[0].code = DVI$_DEVCLASS;
    items[0].bufadr = &devclass;
    items[0].retadr = NULL;
    items[1].len = 0;
    items[1].code = 0;

    status = sys$getdviw
	(NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);

    if ($VMS_STATUS_SUCCESS(status)) {
        status = dvi_iosb[0];
    }

    if (!$VMS_STATUS_SUCCESS(status)) {
        SETERRNO(EVMSERR, status);
	return -1;
    }
    else {
	if (devclass == DC$_TERM) {
	    return 0;
	}
    }
    return -1;
}

/* If we are on a DECTerm, we can pretend to fork xterms when requested */
static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
{
    int status;
    int ret_stat;
    char * ret_char;
    char device_name[65];
    unsigned short device_name_len;
    struct dsc$descriptor_s customization_dsc;
    struct dsc$descriptor_s device_name_dsc;
    const char * cptr;
    char customization[200];
    char title[40];
    pInfo info = NULL;
    char mbx1[64];
    unsigned short p_chan;
    int n;
    unsigned short iosb[4];
    const char * cust_str =
        "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
    struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
                                          DSC$K_CLASS_S, mbx1};

     /* LIB$FIND_IMAGE_SIGNAL needs a handler */
    /*---------------------------------------*/
    VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);


    /* Make sure that this is from the Perl debugger */
    ret_char = strstr(cmd," xterm ");
    if (ret_char == NULL)
	return NULL;
    cptr = ret_char + 7;
    ret_char = strstr(cmd,"tty");
    if (ret_char == NULL)
	return NULL;
    ret_char = strstr(cmd,"sleep");
    if (ret_char == NULL)
	return NULL;

    if (decw_term_port == 0) {
	$DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
	$DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
	$DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");