/*    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, 135-40
 */
 
#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>
#include <smgdef.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

/* More specific prototype than in starlet_c.h makes programming errors
   more visible.
 */
#ifdef sys$getdviw
#undef sys$getdviw
int sys$getdviw
       (unsigned long efn,
        unsigned short chan,
        const struct dsc$descriptor_s * devnam,
        const struct item_list_3 * itmlst,
        void * iosb,
        void * (astadr)(unsigned long),
        void * astprm,
        void * nullarg);
#endif

#ifdef sys$get_security
#undef sys$get_security
int sys$get_security
       (const struct dsc$descriptor_s * clsnam,
        const struct dsc$descriptor_s * objnam,
        const unsigned int *objhan,
        unsigned int flags,
        const struct item_list_3 * itmlst,
        unsigned int * contxt,
        const unsigned int * acmode);
#endif

#ifdef sys$set_security
#undef sys$set_security
int sys$set_security
       (const struct dsc$descriptor_s * clsnam,
        const struct dsc$descriptor_s * objnam,
        const unsigned int *objhan,
        unsigned int flags,
        const struct item_list_3 * itmlst,
        unsigned int * contxt,
        const unsigned int * acmode);
#endif

#ifdef lib$find_image_symbol
#undef lib$find_image_symbol
int lib$find_image_symbol
       (const struct dsc$descriptor_s * imgname,
        const struct dsc$descriptor_s * symname,
        void * symval,
        const struct dsc$descriptor_s * defspec,
        unsigned long flag);
#endif

#ifdef lib$rename_file
#undef lib$rename_file
int lib$rename_file
       (const struct dsc$descriptor_s * old_file_dsc,
        const struct dsc$descriptor_s * new_file_dsc,
        const struct dsc$descriptor_s * default_file_dsc,
        const struct dsc$descriptor_s * related_file_dsc,
        const unsigned long * flags,
        void * (success)(const struct dsc$descriptor_s * old_dsc,
                         const struct dsc$descriptor_s * new_dsc,
                         const void *),
        void * (error)(const struct dsc$descriptor_s * old_dsc,
                       const struct dsc$descriptor_s * new_dsc,
                       const int * rms_sts,
                       const int * rms_stv,
                       const int * error_src,
                       const void * usr_arg),
        int (confirm)(const struct dsc$descriptor_s * old_dsc,
                      const struct dsc$descriptor_s * new_dsc,
                      const void * old_fab,
                      const void * usr_arg),
        void * user_arg,
        struct dsc$descriptor_s * old_result_name_dsc,
        struct dsc$descriptor_s * new_result_name_dsc,
        unsigned long * file_scan_context);
#endif

#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

/* 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 *);

/* 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_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;

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

static int vms_debug_on_exception = 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 scnt;
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 '^':
        /* 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;
}

#ifdef sys$filescan
#undef sys$filescan
int sys$filescan
   (const struct dsc$descriptor_s * srcstr,
    struct filescan_itmlst_2 * valuelist,
    unsigned long * fldflags,
    struct dsc$descriptor_s *auxout,
    unsigned short * retlen);
#endif

/* 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;
    *dir_len;
    *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 probalby 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;
}


/* 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, *end;
          int i;
          if (!environ) {
            ivenv = 1; 
            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 accomodate possible long value */
          _ckvmssts(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 (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(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(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)
{
  return vmstrnenv(lnm,eqv,idx,fildev,                                   
#ifdef SECURE_INTERNAL_GETENV
                   (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
#else
                   0
#endif
                                                                              );
}
/*}}}*/

/* 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 trnsuccess, 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 : Nullch;
    }

}  /* 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 : Nullch;
    }

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

static void create_mbx(pTHX_ 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 = Nullch;
  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, wakect = 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 {
      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
 */
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 delimitors 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 implemenation 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(SS$_INSFMEM);

    rslt = do_rmsexpand(name,
                        vmsname,
                        0,
                        NULL,
                        PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
                        NULL,
                        NULL);
    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(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(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;

    dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
    if (dirfile == NULL)
        _ckvmssts(SS$_INSFMEM);

    /* Force to a directory specification */
    if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
        PerlMem_free(dirfile);
        return -1;
    }
    if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
        errno = ENOTDIR;
        retval = -1;
    }
    else
        retval = mp_do_kill_file(aTHX_ dirfile, 1);

    PerlMem_free(dirfile);
    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 rspec[NAM$C_MAXRSS+1];
    char *tspec;
    Stat_t st;
    int rmsts;

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

   rmsts = mp_do_kill_file(aTHX_ name, 0);

    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.
   *
   * - Preview- '/' will be valid soon on VMS
   */
  if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
    char *newdir = savepvn(dir1,dirlen-1);
    int ret = chdir(newdir);
    Safefree(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)
{
  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.
   */
  if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
    char *vms_src, *vms_dir, *rslt;
    int ret = -1;
    errno = EIO;

    /* First convert this to a VMS format specification */
    vms_src = PerlMem_malloc(VMS_MAXRSS);
    if (vms_src == NULL)
        _ckvmssts(SS$_INSFMEM);

    rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
    if (rslt == NULL) {
        /* If we fail, then not a file specification */
        PerlMem_free(vms_src);
        errno = EIO;
        return -1;
    }

    /* Now make it a directory spec so chmod is happy */
    vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
    if (vms_dir == NULL)
        _ckvmssts(SS$_INSFMEM);
    rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
    PerlMem_free(vms_src);

    /* Now do it */
    if (rslt != NULL) {
        ret = chmod(vms_dir, mode);
    } else {
        errno = EIO;
    }
    PerlMem_free(vms_dir);
    return ret;
  }
  else return chmod(file_spec, mode);
}  /* 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)
{
    dTHX;
    int iss;
    unsigned int code;
    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(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$_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 */
    }

  return SS$_ABORT; /* Should not get here */
} 


/* default piping mailbox size */
#define PERL_BUFSIZ        512


static void
create_mbx(pTHX_ 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(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(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));

  _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
  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(pTHX)
{
    pInfo info;
    unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
    int sts, did_stuff, need_eof, 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 (!info->useFILE
#if defined(USE_ITHREADS)
             && my_perl
#endif
             && PL_perlio_fd_refcnt) 
               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) {
      int need_eof;
      _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 ((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;
  int sts;
  pXpipe x;

  info->completion &= 0x0FFFFFFF; /* strip off "control" field */
  closed_list[closed_index].pid = info->pid;