vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  * Version: 5.7.0
   5  *
   6  * August 2005 Convert VMS status code to UNIX status codes
   7  * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
   8  *             and Perl_cando by Craig Berry
   9  * 29-Aug-2000 Charles Lane's piping improvements rolled in
  10  * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  11  */
  12
  13 #include <acedef.h>
  14 #include <acldef.h>
  15 #include <armdef.h>
  16 #include <atrdef.h>
  17 #include <chpdef.h>
  18 #include <clidef.h>
  19 #include <climsgdef.h>
  20 #include <descrip.h>
  21 #include <devdef.h>
  22 #include <dvidef.h>
  23 #include <fibdef.h>
  24 #include <float.h>
  25 #include <fscndef.h>
  26 #include <iodef.h>
  27 #include <jpidef.h>
  28 #include <kgbdef.h>
  29 #include <libclidef.h>
  30 #include <libdef.h>
  31 #include <lib$routines.h>
  32 #include <lnmdef.h>
  33 #include <msgdef.h>
  34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  35 #include <ppropdef.h>
  36 #endif
  37 #include <prvdef.h>
  38 #include <psldef.h>
  39 #include <rms.h>
  40 #include <shrdef.h>
  41 #include <ssdef.h>
  42 #include <starlet.h>
  43 #include <strdef.h>
  44 #include <str$routines.h>
  45 #include <syidef.h>
  46 #include <uaidef.h>
  47 #include <uicdef.h>
  48 #include <stsdef.h>
  49 #include <rmsdef.h>
  50
  51 /* Set the maximum filespec size here as it is larger for EFS file
  52  * specifications.
  53  * Not fully implemented at this time because the larger size
  54  * will likely impact the stack local storage requirements of
  55  * threaded code, and probably cause hard to diagnose failures.
  56  * To implement the larger sizes, all places where filename
  57  * storage is put on the stack need to be changed to use
  58  * New()/SafeFree() instead.
  59  */
  60 #ifndef __VAX
  61 #ifndef VMS_MAXRSS
  62 #ifdef NAML$C_MAXRSS
  63 #define VMS_MAXRSS (NAML$C_MAXRSS+1)
  64 #ifndef VMS_LONGNAME_SUPPORT
  65 #define VMS_LONGNAME_SUPPORT 1
  66 #endif /* VMS_LONGNAME_SUPPORT */
  67 #endif /* NAML$C_MAXRSS */
  68 #endif /* VMS_MAXRSS */
  69 #endif
  70
  71 /* temporary hack until support is complete */
  72 #ifdef VMS_LONGNAME_SUPPORT
  73 #undef VMS_LONGNAME_SUPPORT
  74 #undef VMS_MAXRSS
  75 #endif
  76 /* end of temporary hack until support is complete */
  77
  78 #ifndef VMS_MAXRSS
  79 #define VMS_MAXRSS (NAM$C_MAXRSS + 1)
  80 #endif
  81
  82 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  83 int   decc$feature_get_index(const char *name);
  84 char* decc$feature_get_name(int index);
  85 int   decc$feature_get_value(int index, int mode);
  86 int   decc$feature_set_value(int index, int mode, int value);
  87 #else
  88 #include <unixlib.h>
  89 #endif
  90
  91 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  92
  93 static int set_feature_default(const char *name, int value)
  94 {
  95     int status;
  96     int index;
  97
  98     index = decc$feature_get_index(name);
  99
 100     status = decc$feature_set_value(index, 1, value);
 101     if (index == -1 || (status == -1)) {
 102       return -1;
 103     }
 104
 105     status = decc$feature_get_value(index, 1);
 106     if (status != value) {
 107       return -1;
 108     }
 109
 110 return 0;
 111 }
 112 #endif
 113
 114 /* Older versions of ssdef.h don't have these */
 115 #ifndef SS$_INVFILFOROP
 116 #  define SS$_INVFILFOROP 3930
 117 #endif
 118 #ifndef SS$_NOSUCHOBJECT
 119 #  define SS$_NOSUCHOBJECT 2696
 120 #endif
 121
 122 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 123 #define PERLIO_NOT_STDIO 0
 124
 125 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 126  * code below needs to get to the underlying CRTL routines. */
 127 #define DONT_MASK_RTL_CALLS
 128 #include "EXTERN.h"
 129 #include "perl.h"
 130 #include "XSUB.h"
 131 /* Anticipating future expansion in lexical warnings . . . */
 132 #ifndef WARN_INTERNAL
 133 #  define WARN_INTERNAL WARN_MISC
 134 #endif
 135
 136 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 137 #  define RTL_USES_UTC 1
 138 #endif
 139
 140
 141 /* gcc's header files don't #define direct access macros
 142  * corresponding to VAXC's variant structs */
 143 #ifdef __GNUC__
 144 #  define uic$v_format uic$r_uic_form.uic$v_format
 145 #  define uic$v_group uic$r_uic_form.uic$v_group
 146 #  define uic$v_member uic$r_uic_form.uic$v_member
 147 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 148 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 149 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 150 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 151 #endif
 152
 153 #if defined(NEED_AN_H_ERRNO)
 154 dEXT int h_errno;
 155 #endif
 156
 157 #ifdef __DECC
 158 #pragma message disable pragma
 159 #pragma member_alignment save
 160 #pragma nomember_alignment longword
 161 #pragma message save
 162 #pragma message disable misalgndmem
 163 #endif
 164 struct itmlst_3 {
 165   unsigned short int buflen;
 166   unsigned short int itmcode;
 167   void *bufadr;
 168   unsigned short int *retlen;
 169 };
 170 #ifdef __DECC
 171 #pragma message restore
 172 #pragma member_alignment restore
 173 #endif
 174
 175 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
 176 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
 177 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
 178 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
 179 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
 180 #define do_vms_realpath(a,b)            mp_do_vms_realpath(aTHX_ a,b)
 181 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
 182 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
 183 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 184 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 185 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 186
 187 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
 188 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
 189 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
 190 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
 191
 192 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 193 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 194
 195 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 196  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 197  * the Perl facility.
 198  */
 199 #define PERL_LNM_MAX_ITER 10
 200
 201   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 202 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 203 #define MAX_DCL_SYMBOL          (8192)
 204 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 205 #else
 206 #define MAX_DCL_SYMBOL          (1024)
 207 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 208 #endif
 209
 210 static char *__mystrtolower(char *str)
 211 {
 212   if (str) for (; *str; ++str) *str= tolower(*str);
 213   return str;
 214 }
 215
 216 static struct dsc$descriptor_s fildevdsc =
 217   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 218 static struct dsc$descriptor_s crtlenvdsc =
 219   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 220 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 221 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 222 static struct dsc$descriptor_s **env_tables = defenv;
 223 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 224
 225 /* True if we shouldn't treat barewords as logicals during directory */
 226 /* munching */
 227 static int no_translate_barewords;
 228
 229 #ifndef RTL_USES_UTC
 230 static int tz_updated = 1;
 231 #endif
 232
 233 /* DECC Features that may need to affect how Perl interprets
 234  * displays filename information
 235  */
 236 static int decc_disable_to_vms_logname_translation = 1;
 237 static int decc_disable_posix_root = 1;
 238 int decc_efs_case_preserve = 0;
 239 static int decc_efs_charset = 0;
 240 static int decc_filename_unix_no_version = 0;
 241 static int decc_filename_unix_only = 0;
 242 int decc_filename_unix_report = 0;
 243 int decc_posix_compliant_pathnames = 0;
 244 int decc_readdir_dropdotnotype = 0;
 245 static int vms_process_case_tolerant = 1;
 246
 247 /* bug workarounds if needed */
 248 int decc_bug_readdir_efs1 = 0;
 249 int decc_bug_devnull = 0;
 250 int decc_bug_fgetname = 0;
 251 int decc_dir_barename = 0;
 252
 253 /* Is this a UNIX file specification?
 254  *   No longer a simple check with EFS file specs
 255  *   For now, not a full check, but need to
 256  *   handle POSIX ^UP^ specifications
 257  *   Fixing to handle ^/ cases would require
 258  *   changes to many other conversion routines.
 259  */
 260
 261 static is_unix_filespec(const char *path)
 262 {
 263 int ret_val;
 264 const char * pch1;
 265
 266     ret_val = 0;
 267     if (strncmp(path,"\"^UP^",5) != 0) {
 268         pch1 = strchr(path, '/');
 269         if (pch1 != NULL)
 270             ret_val = 1;
 271         else {
 272
 273             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 274             if (decc_filename_unix_report || decc_filename_unix_only) {
 275             if (strcmp(path,".") == 0)
 276                 ret_val = 1;
 277             }
 278         }
 279     }
 280     return ret_val;
 281 }
 282
 283
 284 /* my_maxidx
 285  * Routine to retrieve the maximum equivalence index for an input
 286  * logical name.  Some calls to this routine have no knowledge if
 287  * the variable is a logical or not.  So on error we return a max
 288  * index of zero.
 289  */
 290 /*{{{int my_maxidx(const char *lnm) */
 291 static int
 292 my_maxidx(const char *lnm)
 293 {
 294     int status;
 295     int midx;
 296     int attr = LNM$M_CASE_BLIND;
 297     struct dsc$descriptor lnmdsc;
 298     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 299                                 {0, 0, 0, 0}};
 300
 301     lnmdsc.dsc$w_length = strlen(lnm);
 302     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 303     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 304     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 305
 306     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 307     if ((status & 1) == 0)
 308        midx = 0;
 309
 310     return (midx);
 311 }
 312 /*}}}*/
 313
 314 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 315 int
 316 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 317   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 318 {
 319     const char *cp1;
 320     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 321     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 322     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 323     int midx;
 324     unsigned char acmode;
 325     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 326                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 327     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 328                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 329                                  {0, 0, 0, 0}};
 330     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 331 #if defined(PERL_IMPLICIT_CONTEXT)
 332     pTHX = NULL;
 333     if (PL_curinterp) {
 334       aTHX = PERL_GET_INTERP;
 335     } else {
 336       aTHX = NULL;
 337     }
 338 #endif
 339
 340     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 341       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 342     }
 343     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 344       *cp2 = _toupper(*cp1);
 345       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 346         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 347         return 0;
 348       }
 349     }
 350     lnmdsc.dsc$w_length = cp1 - lnm;
 351     lnmdsc.dsc$a_pointer = uplnm;
 352     uplnm[lnmdsc.dsc$w_length] = '\0';
 353     secure = flags & PERL__TRNENV_SECURE;
 354     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 355     if (!tabvec || !*tabvec) tabvec = env_tables;
 356
 357     for (curtab = 0; tabvec[curtab]; curtab++) {
 358       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 359         if (!ivenv && !secure) {
 360           char *eq, *end;
 361           int i;
 362           if (!environ) {
 363             ivenv = 1;
 364             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 365             continue;
 366           }
 367           retsts = SS$_NOLOGNAM;
 368           for (i = 0; environ[i]; i++) {
 369             if ((eq = strchr(environ[i],'=')) &&
 370                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 371                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 372               eq++;
 373               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 374               if (!eqvlen) continue;
 375               retsts = SS$_NORMAL;
 376               break;
 377             }
 378           }
 379           if (retsts != SS$_NOLOGNAM) break;
 380         }
 381       }
 382       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 383                !str$case_blind_compare(&tmpdsc,&clisym)) {
 384         if (!ivsym && !secure) {
 385           unsigned short int deflen = LNM$C_NAMLENGTH;
 386           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 387           /* dynamic dsc to accomodate possible long value */
 388           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 389           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 390           if (retsts & 1) {
 391             if (eqvlen > MAX_DCL_SYMBOL) {
 392               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 393               eqvlen = MAX_DCL_SYMBOL;
 394               /* Special hack--we might be called before the interpreter's */
 395               /* fully initialized, in which case either thr or PL_curcop */
 396               /* might be bogus. We have to check, since ckWARN needs them */
 397               /* both to be valid if running threaded */
 398                 if (ckWARN(WARN_MISC)) {
 399                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 400                 }
 401             }
 402             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 403           }
 404           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 405           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 406           if (retsts == LIB$_NOSUCHSYM) continue;
 407           break;
 408         }
 409       }
 410       else if (!ivlnm) {
 411         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 412           midx = my_maxidx(lnm);
 413           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 414             lnmlst[1].bufadr = cp2;
 415             eqvlen = 0;
 416             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 417             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 418             if (retsts == SS$_NOLOGNAM) break;
 419             /* PPFs have a prefix */
 420             if (
 421 #if INTSIZE == 4
 422                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 423 #endif
 424                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 425                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 426                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 427                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 428                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 429               memmove(eqv,eqv+4,eqvlen-4);
 430               eqvlen -= 4;
 431             }
 432             cp2 += eqvlen;
 433             *cp2 = '\0';
 434           }
 435           if ((retsts == SS$_IVLOGNAM) ||
 436               (retsts == SS$_NOLOGNAM)) { continue; }
 437         }
 438         else {
 439           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 440           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 441           if (retsts == SS$_NOLOGNAM) continue;
 442           eqv[eqvlen] = '\0';
 443         }
 444         eqvlen = strlen(eqv);
 445         break;
 446       }
 447     }
 448     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 449     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 450              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 451              retsts == SS$_NOLOGNAM) {
 452       set_errno(EINVAL);  set_vaxc_errno(retsts);
 453     }
 454     else _ckvmssts(retsts);
 455     return 0;
 456 }  /* end of vmstrnenv */
 457 /*}}}*/
 458
 459 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 460 /* Define as a function so we can access statics. */
 461 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 462 {
 463   return vmstrnenv(lnm,eqv,idx,fildev,
 464 #ifdef SECURE_INTERNAL_GETENV
 465                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 466 #else
 467                    0
 468 #endif
 469                                                                               );
 470 }
 471 /*}}}*/
 472
 473 /* my_getenv
 474  * Note: Uses Perl temp to store result so char * can be returned to
 475  * caller; this pointer will be invalidated at next Perl statement
 476  * transition.
 477  * We define this as a function rather than a macro in terms of my_getenv_len()
 478  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 479  * allocate SVs).
 480  */
 481 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 482 char *
 483 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 484 {
 485     const char *cp1;
 486     static char *__my_getenv_eqv = NULL;
 487     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 488     unsigned long int idx = 0;
 489     int trnsuccess, success, secure, saverr, savvmserr;
 490     int midx, flags;
 491     SV *tmpsv;
 492
 493     midx = my_maxidx(lnm) + 1;
 494
 495     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 496       /* Set up a temporary buffer for the return value; Perl will
 497        * clean it up at the next statement transition */
 498       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 499       if (!tmpsv) return NULL;
 500       eqv = SvPVX(tmpsv);
 501     }
 502     else {
 503       /* Assume no interpreter ==> single thread */
 504       if (__my_getenv_eqv != NULL) {
 505         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 506       }
 507       else {
 508         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
 509       }
 510       eqv = __my_getenv_eqv;
 511     }
 512
 513     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 514     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
 515       int len;
 516       getcwd(eqv,LNM$C_NAMLENGTH);
 517
 518       len = strlen(eqv);
 519
 520       /* Get rid of "000000/ in rooted filespecs */
 521       if (len > 7) {
 522         char * zeros;
 523         zeros = strstr(eqv, "/000000/");
 524         if (zeros != NULL) {
 525           int mlen;
 526           mlen = len - (zeros - eqv) - 7;
 527           memmove(zeros, &zeros[7], mlen);
 528           len = len - 7;
 529           eqv[len] = '\0';
 530         }
 531       }
 532       return eqv;
 533     }
 534     else {
 535       /* Impose security constraints only if tainting */
 536       if (sys) {
 537         /* Impose security constraints only if tainting */
 538         secure = PL_curinterp ? PL_tainting : will_taint;
 539         saverr = errno;  savvmserr = vaxc$errno;
 540       }
 541       else {
 542         secure = 0;
 543       }
 544
 545       flags =
 546 #ifdef SECURE_INTERNAL_GETENV
 547               secure ? PERL__TRNENV_SECURE : 0
 548 #else
 549               0
 550 #endif
 551       ;
 552
 553       /* For the getenv interface we combine all the equivalence names
 554        * of a search list logical into one value to acquire a maximum
 555        * value length of 255*128 (assuming %ENV is using logicals).
 556        */
 557       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 558
 559       /* If the name contains a semicolon-delimited index, parse it
 560        * off and make sure we only retrieve the equivalence name for
 561        * that index.  */
 562       if ((cp2 = strchr(lnm,';')) != NULL) {
 563         strcpy(uplnm,lnm);
 564         uplnm[cp2-lnm] = '\0';
 565         idx = strtoul(cp2+1,NULL,0);
 566         lnm = uplnm;
 567         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 568       }
 569
 570       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
 571
 572       /* Discard NOLOGNAM on internal calls since we're often looking
 573        * for an optional name, and this "error" often shows up as the
 574        * (bogus) exit status for a die() call later on.  */
 575       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 576       return success ? eqv : Nullch;
 577     }
 578
 579 }  /* end of my_getenv() */
 580 /*}}}*/
 581
 582
 583 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 584 char *
 585 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 586 {
 587     const char *cp1;
 588     char *buf, *cp2;
 589     unsigned long idx = 0;
 590     int midx, flags;
 591     static char *__my_getenv_len_eqv = NULL;
 592     int secure, saverr, savvmserr;
 593     SV *tmpsv;
 594
 595     midx = my_maxidx(lnm) + 1;
 596
 597     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 598       /* Set up a temporary buffer for the return value; Perl will
 599        * clean it up at the next statement transition */
 600       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 601       if (!tmpsv) return NULL;
 602       buf = SvPVX(tmpsv);
 603     }
 604     else {
 605       /* Assume no interpreter ==> single thread */
 606       if (__my_getenv_len_eqv != NULL) {
 607         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 608       }
 609       else {
 610         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
 611       }
 612       buf = __my_getenv_len_eqv;
 613     }
 614
 615     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
 616     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
 617     char * zeros;
 618
 619       getcwd(buf,LNM$C_NAMLENGTH);
 620       *len = strlen(buf);
 621
 622       /* Get rid of "000000/ in rooted filespecs */
 623       if (*len > 7) {
 624       zeros = strstr(buf, "/000000/");
 625       if (zeros != NULL) {
 626         int mlen;
 627         mlen = *len - (zeros - buf) - 7;
 628         memmove(zeros, &zeros[7], mlen);
 629         *len = *len - 7;
 630         buf[*len] = '\0';
 631         }
 632       }
 633       return buf;
 634     }
 635     else {
 636       if (sys) {
 637         /* Impose security constraints only if tainting */
 638         secure = PL_curinterp ? PL_tainting : will_taint;
 639         saverr = errno;  savvmserr = vaxc$errno;
 640       }
 641       else {
 642         secure = 0;
 643       }
 644
 645       flags =
 646 #ifdef SECURE_INTERNAL_GETENV
 647               secure ? PERL__TRNENV_SECURE : 0
 648 #else
 649               0
 650 #endif
 651       ;
 652
 653       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
 654
 655       if ((cp2 = strchr(lnm,';')) != NULL) {
 656         strcpy(buf,lnm);
 657         buf[cp2-lnm] = '\0';
 658         idx = strtoul(cp2+1,NULL,0);
 659         lnm = buf;
 660         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
 661       }
 662
 663       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
 664
 665       /* Get rid of "000000/ in rooted filespecs */
 666       if (*len > 7) {
 667       char * zeros;
 668         zeros = strstr(buf, "/000000/");
 669         if (zeros != NULL) {
 670           int mlen;
 671           mlen = *len - (zeros - buf) - 7;
 672           memmove(zeros, &zeros[7], mlen);
 673           *len = *len - 7;
 674           buf[*len] = '\0';
 675         }
 676       }
 677
 678       /* Discard NOLOGNAM on internal calls since we're often looking
 679        * for an optional name, and this "error" often shows up as the
 680        * (bogus) exit status for a die() call later on.  */
 681       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
 682       return *len ? buf : Nullch;
 683     }
 684
 685 }  /* end of my_getenv_len() */
 686 /*}}}*/
 687
 688 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 689
 690 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 691
 692 /*{{{ void prime_env_iter() */
 693 void
 694 prime_env_iter(void)
 695 /* Fill the %ENV associative array with all logical names we can
 696  * find, in preparation for iterating over it.
 697  */
 698 {
 699   static int primed = 0;
 700   HV *seenhv = NULL, *envhv;
 701   SV *sv = NULL;
 702   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
 703   unsigned short int chan;
 704 #ifndef CLI$M_TRUSTED
 705 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 706 #endif
 707   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
 708   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
 709   long int i;
 710   bool have_sym = FALSE, have_lnm = FALSE;
 711   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 712   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
 713   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
 714   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 715   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
 716 #if defined(PERL_IMPLICIT_CONTEXT)
 717   pTHX;
 718 #endif
 719 #if defined(USE_ITHREADS)
 720   static perl_mutex primenv_mutex;
 721   MUTEX_INIT(&primenv_mutex);
 722 #endif
 723
 724 #if defined(PERL_IMPLICIT_CONTEXT)
 725     /* We jump through these hoops because we can be called at */
 726     /* platform-specific initialization time, which is before anything is */
 727     /* set up--we can't even do a plain dTHX since that relies on the */
 728     /* interpreter structure to be initialized */
 729     if (PL_curinterp) {
 730       aTHX = PERL_GET_INTERP;
 731     } else {
 732       aTHX = NULL;
 733     }
 734 #endif
 735
 736   if (primed || !PL_envgv) return;
 737   MUTEX_LOCK(&primenv_mutex);
 738   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
 739   envhv = GvHVn(PL_envgv);
 740   /* Perform a dummy fetch as an lval to insure that the hash table is
 741    * set up.  Otherwise, the hv_store() will turn into a nullop. */
 742   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
 743
 744   for (i = 0; env_tables[i]; i++) {
 745      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 746          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
 747      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
 748   }
 749   if (have_sym || have_lnm) {
 750     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
 751     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
 752     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
 753     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
 754   }
 755
 756   for (i--; i >= 0; i--) {
 757     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
 758       char *start;
 759       int j;
 760       for (j = 0; environ[j]; j++) {
 761         if (!(start = strchr(environ[j],'='))) {
 762           if (ckWARN(WARN_INTERNAL))
 763             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
 764         }
 765         else {
 766           start++;
 767           sv = newSVpv(start,0);
 768           SvTAINTED_on(sv);
 769           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
 770         }
 771       }
 772       continue;
 773     }
 774     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
 775              !str$case_blind_compare(&tmpdsc,&clisym)) {
 776       strcpy(cmd,"Show Symbol/Global *");
 777       cmddsc.dsc$w_length = 20;
 778       if (env_tables[i]->dsc$w_length == 12 &&
 779           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
 780           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
 781       flags = defflags | CLI$M_NOLOGNAM;
 782     }
 783     else {
 784       strcpy(cmd,"Show Logical *");
 785       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
 786         strcat(cmd," /Table=");
 787         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
 788         cmddsc.dsc$w_length = strlen(cmd);
 789       }
 790       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
 791       flags = defflags | CLI$M_NOCLISYM;
 792     }
 793
 794     /* Create a new subprocess to execute each command, to exclude the
 795      * remote possibility that someone could subvert a mbx or file used
 796      * to write multiple commands to a single subprocess.
 797      */
 798     do {
 799       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
 800                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
 801       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
 802       defflags &= ~CLI$M_TRUSTED;
 803     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
 804     _ckvmssts(retsts);
 805     if (!buf) Newx(buf,mbxbufsiz + 1,char);
 806     if (seenhv) SvREFCNT_dec(seenhv);
 807     seenhv = newHV();
 808     while (1) {
 809       char *cp1, *cp2, *key;
 810       unsigned long int sts, iosb[2], retlen, keylen;
 811       register U32 hash;
 812
 813       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
 814       if (sts & 1) sts = iosb[0] & 0xffff;
 815       if (sts == SS$_ENDOFFILE) {
 816         int wakect = 0;
 817         while (substs == 0) { sys$hiber(); wakect++;}
 818         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
 819         _ckvmssts(substs);
 820         break;
 821       }
 822       _ckvmssts(sts);
 823       retlen = iosb[0] >> 16;
 824       if (!retlen) continue;  /* blank line */
 825       buf[retlen] = '\0';
 826       if (iosb[1] != subpid) {
 827         if (iosb[1]) {
 828           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
 829         }
 830         continue;
 831       }
 832       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
 833         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
 834
 835       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
 836       if (*cp1 == '(' || /* Logical name table name */
 837           *cp1 == '='    /* Next eqv of searchlist  */) continue;
 838       if (*cp1 == '"') cp1++;
 839       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
 840       key = cp1;  keylen = cp2 - cp1;
 841       if (keylen && hv_exists(seenhv,key,keylen)) continue;
 842       while (*cp2 && *cp2 != '=') cp2++;
 843       while (*cp2 && *cp2 == '=') cp2++;
 844       while (*cp2 && *cp2 == ' ') cp2++;
 845       if (*cp2 == '"') {  /* String translation; may embed "" */
 846         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
 847         cp2++;  cp1--; /* Skip "" surrounding translation */
 848       }
 849       else {  /* Numeric translation */
 850         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
 851         cp1--;  /* stop on last non-space char */
 852       }
 853       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
 854         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
 855         continue;
 856       }
 857       PERL_HASH(hash,key,keylen);
 858
 859       if (cp1 == cp2 && *cp2 == '.') {
 860         /* A single dot usually means an unprintable character, such as a null
 861          * to indicate a zero-length value.  Get the actual value to make sure.
 862          */
 863         char lnm[LNM$C_NAMLENGTH+1];
 864         char eqv[MAX_DCL_SYMBOL+1];
 865         strncpy(lnm, key, keylen);
 866         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
 867         sv = newSVpvn(eqv, strlen(eqv));
 868       }
 869       else {
 870         sv = newSVpvn(cp2,cp1 - cp2 + 1);
 871       }
 872
 873       SvTAINTED_on(sv);
 874       hv_store(envhv,key,keylen,sv,hash);
 875       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
 876     }
 877     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
 878       /* get the PPFs for this process, not the subprocess */
 879       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
 880       char eqv[LNM$C_NAMLENGTH+1];
 881       int trnlen, i;
 882       for (i = 0; ppfs[i]; i++) {
 883         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
 884         sv = newSVpv(eqv,trnlen);
 885         SvTAINTED_on(sv);
 886         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
 887       }
 888     }
 889   }
 890   primed = 1;
 891   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
 892   if (buf) Safefree(buf);
 893   if (seenhv) SvREFCNT_dec(seenhv);
 894   MUTEX_UNLOCK(&primenv_mutex);
 895   return;
 896
 897 }  /* end of prime_env_iter */
 898 /*}}}*/
 899
 900
 901 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
 902 /* Define or delete an element in the same "environment" as
 903  * vmstrnenv().  If an element is to be deleted, it's removed from
 904  * the first place it's found.  If it's to be set, it's set in the
 905  * place designated by the first element of the table vector.
 906  * Like setenv() returns 0 for success, non-zero on error.
 907  */
 908 int
 909 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
 910 {
 911     const char *cp1;
 912     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
 913     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
 914     int nseg = 0, j;
 915     unsigned long int retsts, usermode = PSL$C_USER;
 916     struct itmlst_3 *ile, *ilist;
 917     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
 918                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 919                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 920     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 921     $DESCRIPTOR(local,"_LOCAL");
 922
 923     if (!lnm) {
 924         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 925         return SS$_IVLOGNAM;
 926     }
 927
 928     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 929       *cp2 = _toupper(*cp1);
 930       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 931         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 932         return SS$_IVLOGNAM;
 933       }
 934     }
 935     lnmdsc.dsc$w_length = cp1 - lnm;
 936     if (!tabvec || !*tabvec) tabvec = env_tables;
 937
 938     if (!eqv) {  /* we're deleting n element */
 939       for (curtab = 0; tabvec[curtab]; curtab++) {
 940         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 941         int i;
 942           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
 943             if ((cp1 = strchr(environ[i],'=')) &&
 944                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
 945                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
 946 #ifdef HAS_SETENV
 947               return setenv(lnm,"",1) ? vaxc$errno : 0;
 948             }
 949           }
 950           ivenv = 1; retsts = SS$_NOLOGNAM;
 951 #else
 952               if (ckWARN(WARN_INTERNAL))
 953                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
 954               ivenv = 1; retsts = SS$_NOSUCHPGM;
 955               break;
 956             }
 957           }
 958 #endif
 959         }
 960         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 961                  !str$case_blind_compare(&tmpdsc,&clisym)) {
 962           unsigned int symtype;
 963           if (tabvec[curtab]->dsc$w_length == 12 &&
 964               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
 965               !str$case_blind_compare(&tmpdsc,&local))
 966             symtype = LIB$K_CLI_LOCAL_SYM;
 967           else symtype = LIB$K_CLI_GLOBAL_SYM;
 968           retsts = lib$delete_symbol(&lnmdsc,&symtype);
 969           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 970           if (retsts == LIB$_NOSUCHSYM) continue;
 971           break;
 972         }
 973         else if (!ivlnm) {
 974           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
 975           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 976           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 977           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
 978           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
 979         }
 980       }
 981     }
 982     else {  /* we're defining a value */
 983       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
 984 #ifdef HAS_SETENV
 985         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 986 #else
 987         if (ckWARN(WARN_INTERNAL))
 988           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
 989         retsts = SS$_NOSUCHPGM;
 990 #endif
 991       }
 992       else {
 993         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
 994         eqvdsc.dsc$w_length  = strlen(eqv);
 995         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
 996             !str$case_blind_compare(&tmpdsc,&clisym)) {
 997           unsigned int symtype;
 998           if (tabvec[0]->dsc$w_length == 12 &&
 999               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1000                !str$case_blind_compare(&tmpdsc,&local))
1001             symtype = LIB$K_CLI_LOCAL_SYM;
1002           else symtype = LIB$K_CLI_GLOBAL_SYM;
1003           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1004         }
1005         else {
1006           if (!*eqv) eqvdsc.dsc$w_length = 1;
1007           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1008
1009             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1010             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1011               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1012                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1013               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1014               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1015             }
1016
1017             Newx(ilist,nseg+1,struct itmlst_3);
1018             ile = ilist;
1019             if (!ile) {
1020               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1021               return SS$_INSFMEM;
1022             }
1023             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1024
1025             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1026               ile->itmcode = LNM$_STRING;
1027               ile->bufadr = c;
1028               if ((j+1) == nseg) {
1029                 ile->buflen = strlen(c);
1030                 /* in case we are truncating one that's too long */
1031                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1032               }
1033               else {
1034                 ile->buflen = LNM$C_NAMLENGTH;
1035               }
1036             }
1037
1038             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1039             Safefree (ilist);
1040           }
1041           else {
1042             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1043           }
1044         }
1045       }
1046     }
1047     if (!(retsts & 1)) {
1048       switch (retsts) {
1049         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1050         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1051           set_errno(EVMSERR); break;
1052         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1053         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1054           set_errno(EINVAL); break;
1055         case SS$_NOPRIV:
1056           set_errno(EACCES);
1057         default:
1058           _ckvmssts(retsts);
1059           set_errno(EVMSERR);
1060        }
1061        set_vaxc_errno(retsts);
1062        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1063     }
1064     else {
1065       /* We reset error values on success because Perl does an hv_fetch()
1066        * before each hv_store(), and if the thing we're setting didn't
1067        * previously exist, we've got a leftover error message.  (Of course,
1068        * this fails in the face of
1069        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1070        * in that the error reported in $! isn't spurious,
1071        * but it's right more often than not.)
1072        */
1073       set_errno(0); set_vaxc_errno(retsts);
1074       return 0;
1075     }
1076
1077 }  /* end of vmssetenv() */
1078 /*}}}*/
1079
1080 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1081 /* This has to be a function since there's a prototype for it in proto.h */
1082 void
1083 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1084 {
1085     if (lnm && *lnm) {
1086       int len = strlen(lnm);
1087       if  (len == 7) {
1088         char uplnm[8];
1089         int i;
1090         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1091         if (!strcmp(uplnm,"DEFAULT")) {
1092           if (eqv && *eqv) my_chdir(eqv);
1093           return;
1094         }
1095     }
1096 #ifndef RTL_USES_UTC
1097     if (len == 6 || len == 2) {
1098       char uplnm[7];
1099       int i;
1100       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1101       uplnm[len] = '\0';
1102       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1103       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1104     }
1105 #endif
1106   }
1107   (void) vmssetenv(lnm,eqv,NULL);
1108 }
1109 /*}}}*/
1110
1111 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1112 /*  vmssetuserlnm
1113  *  sets a user-mode logical in the process logical name table
1114  *  used for redirection of sys$error
1115  */
1116 void
1117 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1118 {
1119     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1120     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1121     unsigned long int iss, attr = LNM$M_CONFINE;
1122     unsigned char acmode = PSL$C_USER;
1123     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1124                                  {0, 0, 0, 0}};
1125     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1126     d_name.dsc$w_length = strlen(name);
1127
1128     lnmlst[0].buflen = strlen(eqv);
1129     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1130
1131     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1132     if (!(iss&1)) lib$signal(iss);
1133 }
1134 /*}}}*/
1135
1136
1137 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1138 /* my_crypt - VMS password hashing
1139  * my_crypt() provides an interface compatible with the Unix crypt()
1140  * C library function, and uses sys$hash_password() to perform VMS
1141  * password hashing.  The quadword hashed password value is returned
1142  * as a NUL-terminated 8 character string.  my_crypt() does not change
1143  * the case of its string arguments; in order to match the behavior
1144  * of LOGINOUT et al., alphabetic characters in both arguments must
1145  *  be upcased by the caller.
1146  *
1147  * - fix me to call ACM services when available
1148  */
1149 char *
1150 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1151 {
1152 #   ifndef UAI$C_PREFERRED_ALGORITHM
1153 #     define UAI$C_PREFERRED_ALGORITHM 127
1154 #   endif
1155     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1156     unsigned short int salt = 0;
1157     unsigned long int sts;
1158     struct const_dsc {
1159         unsigned short int dsc$w_length;
1160         unsigned char      dsc$b_type;
1161         unsigned char      dsc$b_class;
1162         const char *       dsc$a_pointer;
1163     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1164        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1165     struct itmlst_3 uailst[3] = {
1166         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1167         { sizeof salt, UAI$_SALT,    &salt, 0},
1168         { 0,           0,            NULL,  NULL}};
1169     static char hash[9];
1170
1171     usrdsc.dsc$w_length = strlen(usrname);
1172     usrdsc.dsc$a_pointer = usrname;
1173     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1174       switch (sts) {
1175         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1176           set_errno(EACCES);
1177           break;
1178         case RMS$_RNF:
1179           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1180           break;
1181         default:
1182           set_errno(EVMSERR);
1183       }
1184       set_vaxc_errno(sts);
1185       if (sts != RMS$_RNF) return NULL;
1186     }
1187
1188     txtdsc.dsc$w_length = strlen(textpasswd);
1189     txtdsc.dsc$a_pointer = textpasswd;
1190     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1191       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1192     }
1193
1194     return (char *) hash;
1195
1196 }  /* end of my_crypt() */
1197 /*}}}*/
1198
1199
1200 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1201 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1202 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1203
1204 /* fixup barenames that are directories for internal use.
1205  * There have been problems with the consistent handling of UNIX
1206  * style directory names when routines are presented with a name that
1207  * has no directory delimitors at all.  So this routine will eventually
1208  * fix the issue.
1209  */
1210 static char * fixup_bare_dirnames(const char * name)
1211 {
1212   if (decc_disable_to_vms_logname_translation) {
1213 /* fix me */
1214   }
1215   return NULL;
1216 }
1217
1218 /* mp_do_kill_file
1219  * A little hack to get around a bug in some implemenation of remove()
1220  * that do not know how to delete a directory
1221  *
1222  * Delete any file to which user has control access, regardless of whether
1223  * delete access is explicitly allowed.
1224  * Limitations: User must have write access to parent directory.
1225  *              Does not block signals or ASTs; if interrupted in midstream
1226  *              may leave file with an altered ACL.
1227  * HANDLE WITH CARE!
1228  */
1229 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1230 static int
1231 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1232 {
1233     char *vmsname, *rspec;
1234     char *remove_name;
1235     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1236     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1237     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1238     struct myacedef {
1239       unsigned char myace$b_length;
1240       unsigned char myace$b_type;
1241       unsigned short int myace$w_flags;
1242       unsigned long int myace$l_access;
1243       unsigned long int myace$l_ident;
1244     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1245                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1246       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1247      struct itmlst_3
1248        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1249                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1250        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1251        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1252        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1253        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1254
1255     /* Expand the input spec using RMS, since the CRTL remove() and
1256      * system services won't do this by themselves, so we may miss
1257      * a file "hiding" behind a logical name or search list. */
1258     Newx(vmsname, NAM$C_MAXRSS+1, char);
1259     if (do_tovmsspec(name,vmsname,0) == NULL) {
1260       Safefree(vmsname);
1261       return -1;
1262     }
1263
1264     if (decc_posix_compliant_pathnames) {
1265       /* In POSIX mode, we prefer to remove the UNIX name */
1266       rspec = vmsname;
1267       remove_name = (char *)name;
1268     }
1269     else {
1270       Newx(rspec, NAM$C_MAXRSS+1, char);
1271       if (do_rmsexpand(vmsname, rspec, 1, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1272         Safefree(rspec);
1273         Safefree(vmsname);
1274         return -1;
1275       }
1276       Safefree(vmsname);
1277       remove_name = rspec;
1278     }
1279
1280 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1281     if (dirflag != 0) {
1282         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1283           Newx(remove_name, NAM$C_MAXRSS+1, char);
1284           do_pathify_dirspec(name, remove_name, 0);
1285           if (!rmdir(remove_name)) {
1286
1287             Safefree(remove_name);
1288             Safefree(rspec);
1289             return 0;   /* Can we just get rid of it? */
1290           }
1291         }
1292         else {
1293           if (!rmdir(remove_name)) {
1294             Safefree(rspec);
1295             return 0;   /* Can we just get rid of it? */
1296           }
1297         }
1298     }
1299     else
1300 #endif
1301       if (!remove(remove_name)) {
1302         Safefree(rspec);
1303         return 0;   /* Can we just get rid of it? */
1304       }
1305
1306     /* If not, can changing protections help? */
1307     if (vaxc$errno != RMS$_PRV) {
1308       Safefree(rspec);
1309       return -1;
1310     }
1311
1312     /* No, so we get our own UIC to use as a rights identifier,
1313      * and the insert an ACE at the head of the ACL which allows us
1314      * to delete the file.
1315      */
1316     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1317     fildsc.dsc$w_length = strlen(rspec);
1318     fildsc.dsc$a_pointer = rspec;
1319     cxt = 0;
1320     newace.myace$l_ident = oldace.myace$l_ident;
1321     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1322       switch (aclsts) {
1323         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1324           set_errno(ENOENT); break;
1325         case RMS$_DIR:
1326           set_errno(ENOTDIR); break;
1327         case RMS$_DEV:
1328           set_errno(ENODEV); break;
1329         case RMS$_SYN: case SS$_INVFILFOROP:
1330           set_errno(EINVAL); break;
1331         case RMS$_PRV:
1332           set_errno(EACCES); break;
1333         default:
1334           _ckvmssts(aclsts);
1335       }
1336       set_vaxc_errno(aclsts);
1337       Safefree(rspec);
1338       return -1;
1339     }
1340     /* Grab any existing ACEs with this identifier in case we fail */
1341     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1342     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1343                     || fndsts == SS$_NOMOREACE ) {
1344       /* Add the new ACE . . . */
1345       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1346         goto yourroom;
1347
1348 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1349       if (dirflag != 0)
1350         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1351           Newx(remove_name, NAM$C_MAXRSS+1, char);
1352           do_pathify_dirspec(name, remove_name, 0);
1353           rmsts = rmdir(remove_name);
1354           Safefree(remove_name);
1355         }
1356         else {
1357         rmsts = rmdir(remove_name);
1358         }
1359       else
1360 #endif
1361         rmsts = remove(remove_name);
1362       if (rmsts) {
1363         /* We blew it - dir with files in it, no write priv for
1364          * parent directory, etc.  Put things back the way they were. */
1365         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1366           goto yourroom;
1367         if (fndsts & 1) {
1368           addlst[0].bufadr = &oldace;
1369           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1370             goto yourroom;
1371         }
1372       }
1373     }
1374
1375     yourroom:
1376     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1377     /* We just deleted it, so of course it's not there.  Some versions of
1378      * VMS seem to return success on the unlock operation anyhow (after all
1379      * the unlock is successful), but others don't.
1380      */
1381     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1382     if (aclsts & 1) aclsts = fndsts;
1383     if (!(aclsts & 1)) {
1384       set_errno(EVMSERR);
1385       set_vaxc_errno(aclsts);
1386       Safefree(rspec);
1387       return -1;
1388     }
1389
1390     Safefree(rspec);
1391     return rmsts;
1392
1393 }  /* end of kill_file() */
1394 /*}}}*/
1395
1396
1397 /*{{{int do_rmdir(char *name)*/
1398 int
1399 Perl_do_rmdir(pTHX_ const char *name)
1400 {
1401     char dirfile[NAM$C_MAXRSS+1];
1402     int retval;
1403     Stat_t st;
1404
1405     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1406     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1407     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1408     return retval;
1409
1410 }  /* end of do_rmdir */
1411 /*}}}*/
1412
1413 /* kill_file
1414  * Delete any file to which user has control access, regardless of whether
1415  * delete access is explicitly allowed.
1416  * Limitations: User must have write access to parent directory.
1417  *              Does not block signals or ASTs; if interrupted in midstream
1418  *              may leave file with an altered ACL.
1419  * HANDLE WITH CARE!
1420  */
1421 /*{{{int kill_file(char *name)*/
1422 int
1423 Perl_kill_file(pTHX_ const char *name)
1424 {
1425     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1426     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1427     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1428     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1429     struct myacedef {
1430       unsigned char myace$b_length;
1431       unsigned char myace$b_type;
1432       unsigned short int myace$w_flags;
1433       unsigned long int myace$l_access;
1434       unsigned long int myace$l_ident;
1435     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1436                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1437       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1438      struct itmlst_3
1439        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1440                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1441        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1442        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1443        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1444        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1445
1446     /* Expand the input spec using RMS, since the CRTL remove() and
1447      * system services won't do this by themselves, so we may miss
1448      * a file "hiding" behind a logical name or search list. */
1449     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1450     if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1451     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1452     /* If not, can changing protections help? */
1453     if (vaxc$errno != RMS$_PRV) return -1;
1454
1455     /* No, so we get our own UIC to use as a rights identifier,
1456      * and the insert an ACE at the head of the ACL which allows us
1457      * to delete the file.
1458      */
1459     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1460     fildsc.dsc$w_length = strlen(rspec);
1461     fildsc.dsc$a_pointer = rspec;
1462     cxt = 0;
1463     newace.myace$l_ident = oldace.myace$l_ident;
1464     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1465       switch (aclsts) {
1466         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1467           set_errno(ENOENT); break;
1468         case RMS$_DIR:
1469           set_errno(ENOTDIR); break;
1470         case RMS$_DEV:
1471           set_errno(ENODEV); break;
1472         case RMS$_SYN: case SS$_INVFILFOROP:
1473           set_errno(EINVAL); break;
1474         case RMS$_PRV:
1475           set_errno(EACCES); break;
1476         default:
1477           _ckvmssts(aclsts);
1478       }
1479       set_vaxc_errno(aclsts);
1480       return -1;
1481     }
1482     /* Grab any existing ACEs with this identifier in case we fail */
1483     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1484     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1485                     || fndsts == SS$_NOMOREACE ) {
1486       /* Add the new ACE . . . */
1487       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1488         goto yourroom;
1489       if ((rmsts = remove(name))) {
1490         /* We blew it - dir with files in it, no write priv for
1491          * parent directory, etc.  Put things back the way they were. */
1492         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1493           goto yourroom;
1494         if (fndsts & 1) {
1495           addlst[0].bufadr = &oldace;
1496           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1497             goto yourroom;
1498         }
1499       }
1500     }
1501
1502     yourroom:
1503     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1504     /* We just deleted it, so of course it's not there.  Some versions of
1505      * VMS seem to return success on the unlock operation anyhow (after all
1506      * the unlock is successful), but others don't.
1507      */
1508     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1509     if (aclsts & 1) aclsts = fndsts;
1510     if (!(aclsts & 1)) {
1511       set_errno(EVMSERR);
1512       set_vaxc_errno(aclsts);
1513       return -1;
1514     }
1515
1516     return rmsts;
1517
1518 }  /* end of kill_file() */
1519 /*}}}*/
1520
1521
1522 /*{{{int my_mkdir(char *,Mode_t)*/
1523 int
1524 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1525 {
1526   STRLEN dirlen = strlen(dir);
1527
1528   /* zero length string sometimes gives ACCVIO */
1529   if (dirlen == 0) return -1;
1530
1531   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1532    * null file name/type.  However, it's commonplace under Unix,
1533    * so we'll allow it for a gain in portability.
1534    */
1535   if (dir[dirlen-1] == '/') {
1536     char *newdir = savepvn(dir,dirlen-1);
1537     int ret = mkdir(newdir,mode);
1538     Safefree(newdir);
1539     return ret;
1540   }
1541   else return mkdir(dir,mode);
1542 }  /* end of my_mkdir */
1543 /*}}}*/
1544
1545 /*{{{int my_chdir(char *)*/
1546 int
1547 Perl_my_chdir(pTHX_ const char *dir)
1548 {
1549   STRLEN dirlen = strlen(dir);
1550
1551   /* zero length string sometimes gives ACCVIO */
1552   if (dirlen == 0) return -1;
1553   const char *dir1;
1554
1555   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1556    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
1557    * so that existing scripts do not need to be changed.
1558    */
1559   dir1 = dir;
1560   while ((dirlen > 0) && (*dir1 == ' ')) {
1561     dir1++;
1562     dirlen--;
1563   }
1564
1565   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1566    * that implies
1567    * null file name/type.  However, it's commonplace under Unix,
1568    * so we'll allow it for a gain in portability.
1569    *
1570    * - Preview- '/' will be valid soon on VMS
1571    */
1572   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1573     char *newdir = savepvn(dir,dirlen-1);
1574     int ret = chdir(newdir);
1575     Safefree(newdir);
1576     return ret;
1577   }
1578   else return chdir(dir);
1579 }  /* end of my_chdir */
1580 /*}}}*/
1581
1582
1583 /*{{{FILE *my_tmpfile()*/
1584 FILE *
1585 my_tmpfile(void)
1586 {
1587   FILE *fp;
1588   char *cp;
1589
1590   if ((fp = tmpfile())) return fp;
1591
1592   Newx(cp,L_tmpnam+24,char);
1593   if (decc_filename_unix_only == 0)
1594     strcpy(cp,"Sys$Scratch:");
1595   else
1596     strcpy(cp,"/tmp/");
1597   tmpnam(cp+strlen(cp));
1598   strcat(cp,".Perltmp");
1599   fp = fopen(cp,"w+","fop=dlt");
1600   Safefree(cp);
1601   return fp;
1602 }
1603 /*}}}*/
1604
1605
1606 #ifndef HOMEGROWN_POSIX_SIGNALS
1607 /*
1608  * The C RTL's sigaction fails to check for invalid signal numbers so we
1609  * help it out a bit.  The docs are correct, but the actual routine doesn't
1610  * do what the docs say it will.
1611  */
1612 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1613 int
1614 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1615                    struct sigaction* oact)
1616 {
1617   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1618         SETERRNO(EINVAL, SS$_INVARG);
1619         return -1;
1620   }
1621   return sigaction(sig, act, oact);
1622 }
1623 /*}}}*/
1624 #endif
1625
1626 #ifdef KILL_BY_SIGPRC
1627 #include <errnodef.h>
1628
1629 /* We implement our own kill() using the undocumented system service
1630    sys$sigprc for one of two reasons:
1631
1632    1.) If the kill() in an older CRTL uses sys$forcex, causing the
1633    target process to do a sys$exit, which usually can't be handled
1634    gracefully...certainly not by Perl and the %SIG{} mechanism.
1635
1636    2.) If the kill() in the CRTL can't be called from a signal
1637    handler without disappearing into the ether, i.e., the signal
1638    it purportedly sends is never trapped. Still true as of VMS 7.3.
1639
1640    sys$sigprc has the same parameters as sys$forcex, but throws an exception
1641    in the target process rather than calling sys$exit.
1642
1643    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1644    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1645    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
1646    with condition codes C$_SIG0+nsig*8, catching the exception on the
1647    target process and resignaling with appropriate arguments.
1648
1649    But we don't have that VMS 7.0+ exception handler, so if you
1650    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
1651
1652    Also note that SIGTERM is listed in the docs as being "unimplemented",
1653    yet always seems to be signaled with a VMS condition code of 4 (and
1654    correctly handled for that code).  So we hardwire it in.
1655
1656    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1657    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
1658    than signalling with an unrecognized (and unhandled by CRTL) code.
1659 */
1660
1661 #define _MY_SIG_MAX 17
1662
1663 unsigned int
1664 Perl_sig_to_vmscondition(int sig)
1665 {
1666     static unsigned int sig_code[_MY_SIG_MAX+1] =
1667     {
1668         0,                  /*  0 ZERO     */
1669         SS$_HANGUP,         /*  1 SIGHUP   */
1670         SS$_CONTROLC,       /*  2 SIGINT   */
1671         SS$_CONTROLY,       /*  3 SIGQUIT  */
1672         SS$_RADRMOD,        /*  4 SIGILL   */
1673         SS$_BREAK,          /*  5 SIGTRAP  */
1674         SS$_OPCCUS,         /*  6 SIGABRT  */
1675         SS$_COMPAT,         /*  7 SIGEMT   */
1676 #ifdef __VAX
1677         SS$_FLTOVF,         /*  8 SIGFPE VAX */
1678 #else
1679         SS$_HPARITH,        /*  8 SIGFPE AXP */
1680 #endif
1681         SS$_ABORT,          /*  9 SIGKILL  */
1682         SS$_ACCVIO,         /* 10 SIGBUS   */
1683         SS$_ACCVIO,         /* 11 SIGSEGV  */
1684         SS$_BADPARAM,       /* 12 SIGSYS   */
1685         SS$_NOMBX,          /* 13 SIGPIPE  */
1686         SS$_ASTFLT,         /* 14 SIGALRM  */
1687         4,                  /* 15 SIGTERM  */
1688         0,                  /* 16 SIGUSR1  */
1689         0                   /* 17 SIGUSR2  */
1690     };
1691
1692 #if __VMS_VER >= 60200000
1693     static int initted = 0;
1694     if (!initted) {
1695         initted = 1;
1696         sig_code[16] = C$_SIGUSR1;
1697         sig_code[17] = C$_SIGUSR2;
1698     }
1699 #endif
1700
1701     if (sig < _SIG_MIN) return 0;
1702     if (sig > _MY_SIG_MAX) return 0;
1703     return sig_code[sig];
1704 }
1705
1706 int
1707 Perl_my_kill(int pid, int sig)
1708 {
1709     dTHX;
1710     int iss;
1711     unsigned int code;
1712     int sys$sigprc(unsigned int *pidadr,
1713                      struct dsc$descriptor_s *prcname,
1714                      unsigned int code);
1715
1716      /* sig 0 means validate the PID */
1717     /*------------------------------*/
1718     if (sig == 0) {
1719         const unsigned long int jpicode = JPI$_PID;
1720         pid_t ret_pid;
1721         int status;
1722         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
1723         if ($VMS_STATUS_SUCCESS(status))
1724            return 0;
1725         switch (status) {
1726         case SS$_NOSUCHNODE:
1727         case SS$_UNREACHABLE:
1728         case SS$_NONEXPR:
1729            errno = ESRCH;
1730            break;
1731         case SS$_NOPRIV:
1732            errno = EPERM;
1733            break;
1734         default:
1735            errno = EVMSERR;
1736         }
1737         vaxc$errno=status;
1738         return -1;
1739     }
1740
1741     code = Perl_sig_to_vmscondition(sig);
1742
1743     if (!code) {
1744         SETERRNO(EINVAL, SS$_BADPARAM);
1745         return -1;
1746     }
1747
1748     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
1749      * signals are to be sent to multiple processes.
1750      *  pid = 0 - all processes in group except ones that the system exempts
1751      *  pid = -1 - all processes except ones that the system exempts
1752      *  pid = -n - all processes in group (abs(n)) except ...
1753      * For now, just report as not supported.
1754      */
1755
1756     if (pid <= 0) {
1757         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
1758         return -1;
1759     }
1760
1761     iss = sys$sigprc((unsigned int *)&pid,0,code);
1762     if (iss&1) return 0;
1763
1764     switch (iss) {
1765       case SS$_NOPRIV:
1766         set_errno(EPERM);  break;
1767       case SS$_NONEXPR:
1768       case SS$_NOSUCHNODE:
1769       case SS$_UNREACHABLE:
1770         set_errno(ESRCH);  break;
1771       case SS$_INSFMEM:
1772         set_errno(ENOMEM); break;
1773       default:
1774         _ckvmssts(iss);
1775         set_errno(EVMSERR);
1776     }
1777     set_vaxc_errno(iss);
1778
1779     return -1;
1780 }
1781 #endif
1782
1783 /* Routine to convert a VMS status code to a UNIX status code.
1784 ** More tricky than it appears because of conflicting conventions with
1785 ** existing code.
1786 **
1787 ** VMS status codes are a bit mask, with the least significant bit set for
1788 ** success.
1789 **
1790 ** Special UNIX status of EVMSERR indicates that no translation is currently
1791 ** available, and programs should check the VMS status code.
1792 **
1793 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
1794 ** decoding.
1795 */
1796
1797 #ifndef C_FACILITY_NO
1798 #define C_FACILITY_NO 0x350000
1799 #endif
1800 #ifndef DCL_IVVERB
1801 #define DCL_IVVERB 0x38090
1802 #endif
1803
1804 int Perl_vms_status_to_unix(int vms_status, int child_flag)
1805 {
1806 int facility;
1807 int fac_sp;
1808 int msg_no;
1809 int msg_status;
1810 int unix_status;
1811
1812   /* Assume the best or the worst */
1813   if (vms_status & STS$M_SUCCESS)
1814     unix_status = 0;
1815   else
1816     unix_status = EVMSERR;
1817
1818   msg_status = vms_status & ~STS$M_CONTROL;
1819
1820   facility = vms_status & STS$M_FAC_NO;
1821   fac_sp = vms_status & STS$M_FAC_SP;
1822   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
1823
1824   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
1825     switch(msg_no) {
1826     case SS$_NORMAL:
1827         unix_status = 0;
1828         break;
1829     case SS$_ACCVIO:
1830         unix_status = EFAULT;
1831         break;
1832     case SS$_DEVOFFLINE:
1833         unix_status = EBUSY;
1834         break;
1835     case SS$_CLEARED:
1836         unix_status = ENOTCONN;
1837         break;
1838     case SS$_IVCHAN:
1839     case SS$_IVLOGNAM:
1840     case SS$_BADPARAM:
1841     case SS$_IVLOGTAB:
1842     case SS$_NOLOGNAM:
1843     case SS$_NOLOGTAB:
1844     case SS$_INVFILFOROP:
1845     case SS$_INVARG:
1846     case SS$_NOSUCHID:
1847     case SS$_IVIDENT:
1848         unix_status = EINVAL;
1849         break;
1850     case SS$_UNSUPPORTED:
1851         unix_status = ENOTSUP;
1852         break;
1853     case SS$_FILACCERR:
1854     case SS$_NOGRPPRV:
1855     case SS$_NOSYSPRV:
1856         unix_status = EACCES;
1857         break;
1858     case SS$_DEVICEFULL:
1859         unix_status = ENOSPC;
1860         break;
1861     case SS$_NOSUCHDEV:
1862         unix_status = ENODEV;
1863         break;
1864     case SS$_NOSUCHFILE:
1865     case SS$_NOSUCHOBJECT:
1866         unix_status = ENOENT;
1867         break;
1868     case SS$_ABORT:                                 /* Fatal case */
1869     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
1870     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
1871         unix_status = EINTR;
1872         break;
1873     case SS$_BUFFEROVF:
1874         unix_status = E2BIG;
1875         break;
1876     case SS$_INSFMEM:
1877         unix_status = ENOMEM;
1878         break;
1879     case SS$_NOPRIV:
1880         unix_status = EPERM;
1881         break;
1882     case SS$_NOSUCHNODE:
1883     case SS$_UNREACHABLE:
1884         unix_status = ESRCH;
1885         break;
1886     case SS$_NONEXPR:
1887         unix_status = ECHILD;
1888         break;
1889     default:
1890         if ((facility == 0) && (msg_no < 8)) {
1891           /* These are not real VMS status codes so assume that they are
1892           ** already UNIX status codes
1893           */
1894           unix_status = msg_no;
1895           break;
1896         }
1897     }
1898   }
1899   else {
1900     /* Translate a POSIX exit code to a UNIX exit code */
1901     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
1902         unix_status = (msg_no & 0x07F8) >> 3;
1903     }
1904     else {
1905
1906          /* Documented traditional behavior for handling VMS child exits */
1907         /*--------------------------------------------------------------*/
1908         if (child_flag != 0) {
1909
1910              /* Success / Informational return 0 */
1911             /*----------------------------------*/
1912             if (msg_no & STS$K_SUCCESS)
1913                 return 0;
1914
1915              /* Warning returns 1 */
1916             /*-------------------*/
1917             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
1918                 return 1;
1919
1920              /* Everything else pass through the severity bits */
1921             /*------------------------------------------------*/
1922             return (msg_no & STS$M_SEVERITY);
1923         }
1924
1925          /* Normal VMS status to ERRNO mapping attempt */
1926         /*--------------------------------------------*/
1927         switch(msg_status) {
1928         /* case RMS$_EOF: */ /* End of File */
1929         case RMS$_FNF:  /* File Not Found */
1930         case RMS$_DNF:  /* Dir Not Found */
1931                 unix_status = ENOENT;
1932                 break;
1933         case RMS$_RNF:  /* Record Not Found */
1934                 unix_status = ESRCH;
1935                 break;
1936         case RMS$_DIR:
1937                 unix_status = ENOTDIR;
1938                 break;
1939         case RMS$_DEV:
1940                 unix_status = ENODEV;
1941                 break;
1942         case RMS$_IFI:
1943         case RMS$_FAC:
1944         case RMS$_ISI:
1945                 unix_status = EBADF;
1946                 break;
1947         case RMS$_FEX:
1948                 unix_status = EEXIST;
1949                 break;
1950         case RMS$_SYN:
1951         case RMS$_FNM:
1952         case LIB$_INVSTRDES:
1953         case LIB$_INVARG:
1954         case LIB$_NOSUCHSYM:
1955         case LIB$_INVSYMNAM:
1956         case DCL_IVVERB:
1957                 unix_status = EINVAL;
1958                 break;
1959         case CLI$_BUFOVF:
1960         case RMS$_RTB:
1961         case CLI$_TKNOVF:
1962         case CLI$_RSLOVF:
1963                 unix_status = E2BIG;
1964                 break;
1965         case RMS$_PRV:  /* No privilege */
1966         case RMS$_ACC:  /* ACP file access failed */
1967         case RMS$_WLK:  /* Device write locked */
1968                 unix_status = EACCES;
1969                 break;
1970         /* case RMS$_NMF: */  /* No more files */
1971         }
1972     }
1973   }
1974
1975   return unix_status;
1976 }
1977
1978 /* Try to guess at what VMS error status should go with a UNIX errno
1979  * value.  This is hard to do as there could be many possible VMS
1980  * error statuses that caused the errno value to be set.
1981  */
1982
1983 int Perl_unix_status_to_vms(int unix_status)
1984 {
1985 int test_unix_status;
1986
1987      /* Trivial cases first */
1988     /*---------------------*/
1989     if (unix_status == EVMSERR)
1990         return vaxc$errno;
1991
1992      /* Is vaxc$errno sane? */
1993     /*---------------------*/
1994     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
1995     if (test_unix_status == unix_status)
1996         return vaxc$errno;
1997
1998      /* If way out of range, must be VMS code already */
1999     /*-----------------------------------------------*/
2000     if (unix_status > EVMSERR)
2001         return unix_status;
2002
2003      /* If out of range, punt */
2004     /*-----------------------*/
2005     if (unix_status > __ERRNO_MAX)
2006         return SS$_ABORT;
2007
2008
2009      /* Ok, now we have to do it the hard way. */
2010     /*----------------------------------------*/
2011     switch(unix_status) {
2012     case 0:     return SS$_NORMAL;
2013     case EPERM: return SS$_NOPRIV;
2014     case ENOENT: return SS$_NOSUCHOBJECT;
2015     case ESRCH: return SS$_UNREACHABLE;
2016     case EINTR: return SS$_ABORT;
2017     /* case EIO: */
2018     /* case ENXIO:  */
2019     case E2BIG: return SS$_BUFFEROVF;
2020     /* case ENOEXEC */
2021     case EBADF: return RMS$_IFI;
2022     case ECHILD: return SS$_NONEXPR;
2023     /* case EAGAIN */
2024     case ENOMEM: return SS$_INSFMEM;
2025     case EACCES: return SS$_FILACCERR;
2026     case EFAULT: return SS$_ACCVIO;
2027     /* case ENOTBLK */
2028     case EBUSY: return SS$_DEVOFFLINE;
2029     case EEXIST: return RMS$_FEX;
2030     /* case EXDEV */
2031     case ENODEV: return SS$_NOSUCHDEV;
2032     case ENOTDIR: return RMS$_DIR;
2033     /* case EISDIR */
2034     case EINVAL: return SS$_INVARG;
2035     /* case ENFILE */
2036     /* case EMFILE */
2037     /* case ENOTTY */
2038     /* case ETXTBSY */
2039     /* case EFBIG */
2040     case ENOSPC: return SS$_DEVICEFULL;
2041     case ESPIPE: return LIB$_INVARG;
2042     /* case EROFS: */
2043     /* case EMLINK: */
2044     /* case EPIPE: */
2045     /* case EDOM */
2046     case ERANGE: return LIB$_INVARG;
2047     /* case EWOULDBLOCK */
2048     /* case EINPROGRESS */
2049     /* case EALREADY */
2050     /* case ENOTSOCK */
2051     /* case EDESTADDRREQ */
2052     /* case EMSGSIZE */
2053     /* case EPROTOTYPE */
2054     /* case ENOPROTOOPT */
2055     /* case EPROTONOSUPPORT */
2056     /* case ESOCKTNOSUPPORT */
2057     /* case EOPNOTSUPP */
2058     /* case EPFNOSUPPORT */
2059     /* case EAFNOSUPPORT */
2060     /* case EADDRINUSE */
2061     /* case EADDRNOTAVAIL */
2062     /* case ENETDOWN */
2063     /* case ENETUNREACH */
2064     /* case ENETRESET */
2065     /* case ECONNABORTED */
2066     /* case ECONNRESET */
2067     /* case ENOBUFS */
2068     /* case EISCONN */
2069     case ENOTCONN: return SS$_CLEARED;
2070     /* case ESHUTDOWN */
2071     /* case ETOOMANYREFS */
2072     /* case ETIMEDOUT */
2073     /* case ECONNREFUSED */
2074     /* case ELOOP */
2075     /* case ENAMETOOLONG */
2076     /* case EHOSTDOWN */
2077     /* case EHOSTUNREACH */
2078     /* case ENOTEMPTY */
2079     /* case EPROCLIM */
2080     /* case EUSERS  */
2081     /* case EDQUOT  */
2082     /* case ENOMSG  */
2083     /* case EIDRM */
2084     /* case EALIGN */
2085     /* case ESTALE */
2086     /* case EREMOTE */
2087     /* case ENOLCK */
2088     /* case ENOSYS */
2089     /* case EFTYPE */
2090     /* case ECANCELED */
2091     /* case EFAIL */
2092     /* case EINPROG */
2093     case ENOTSUP:
2094         return SS$_UNSUPPORTED;
2095     /* case EDEADLK */
2096     /* case ENWAIT */
2097     /* case EILSEQ */
2098     /* case EBADCAT */
2099     /* case EBADMSG */
2100     /* case EABANDONED */
2101     default:
2102         return SS$_ABORT; /* punt */
2103     }
2104
2105   return SS$_ABORT; /* Should not get here */
2106 }
2107
2108
2109 /* default piping mailbox size */
2110 #define PERL_BUFSIZ        512
2111
2112
2113 static void
2114 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2115 {
2116   unsigned long int mbxbufsiz;
2117   static unsigned long int syssize = 0;
2118   unsigned long int dviitm = DVI$_DEVNAM;
2119   char csize[LNM$C_NAMLENGTH+1];
2120   int sts;
2121
2122   if (!syssize) {
2123     unsigned long syiitm = SYI$_MAXBUF;
2124     /*
2125      * Get the SYSGEN parameter MAXBUF
2126      *
2127      * If the logical 'PERL_MBX_SIZE' is defined
2128      * use the value of the logical instead of PERL_BUFSIZ, but
2129      * keep the size between 128 and MAXBUF.
2130      *
2131      */
2132     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2133   }
2134
2135   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2136       mbxbufsiz = atoi(csize);
2137   } else {
2138       mbxbufsiz = PERL_BUFSIZ;
2139   }
2140   if (mbxbufsiz < 128) mbxbufsiz = 128;
2141   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2142
2143   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2144
2145   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2146   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2147
2148 }  /* end of create_mbx() */
2149
2150
2151 /*{{{  my_popen and my_pclose*/
2152
2153 typedef struct _iosb           IOSB;
2154 typedef struct _iosb*         pIOSB;
2155 typedef struct _pipe           Pipe;
2156 typedef struct _pipe*         pPipe;
2157 typedef struct pipe_details    Info;
2158 typedef struct pipe_details*  pInfo;
2159 typedef struct _srqp            RQE;
2160 typedef struct _srqp*          pRQE;
2161 typedef struct _tochildbuf      CBuf;
2162 typedef struct _tochildbuf*    pCBuf;
2163
2164 struct _iosb {
2165     unsigned short status;
2166     unsigned short count;
2167     unsigned long  dvispec;
2168 };
2169
2170 #pragma member_alignment save
2171 #pragma nomember_alignment quadword
2172 struct _srqp {          /* VMS self-relative queue entry */
2173     unsigned long qptr[2];
2174 };
2175 #pragma member_alignment restore
2176 static RQE  RQE_ZERO = {0,0};
2177
2178 struct _tochildbuf {
2179     RQE             q;
2180     int             eof;
2181     unsigned short  size;
2182     char            *buf;
2183 };
2184
2185 struct _pipe {
2186     RQE            free;
2187     RQE            wait;
2188     int            fd_out;
2189     unsigned short chan_in;
2190     unsigned short chan_out;
2191     char          *buf;
2192     unsigned int   bufsize;
2193     IOSB           iosb;
2194     IOSB           iosb2;
2195     int           *pipe_done;
2196     int            retry;
2197     int            type;
2198     int            shut_on_empty;
2199     int            need_wake;
2200     pPipe         *home;
2201     pInfo          info;
2202     pCBuf          curr;
2203     pCBuf          curr2;
2204 #if defined(PERL_IMPLICIT_CONTEXT)
2205     void            *thx;           /* Either a thread or an interpreter */
2206                                     /* pointer, depending on how we're built */
2207 #endif
2208 };
2209
2210
2211 struct pipe_details
2212 {
2213     pInfo           next;
2214     PerlIO *fp;  /* file pointer to pipe mailbox */
2215     int useFILE; /* using stdio, not perlio */
2216     int pid;   /* PID of subprocess */
2217     int mode;  /* == 'r' if pipe open for reading */
2218     int done;  /* subprocess has completed */
2219     int waiting; /* waiting for completion/closure */
2220     int             closing;        /* my_pclose is closing this pipe */
2221     unsigned long   completion;     /* termination status of subprocess */
2222     pPipe           in;             /* pipe in to sub */
2223     pPipe           out;            /* pipe out of sub */
2224     pPipe           err;            /* pipe of sub's sys$error */
2225     int             in_done;        /* true when in pipe finished */
2226     int             out_done;
2227     int             err_done;
2228 };
2229
2230 struct exit_control_block
2231 {
2232     struct exit_control_block *flink;
2233     unsigned long int   (*exit_routine)();
2234     unsigned long int arg_count;
2235     unsigned long int *status_address;
2236     unsigned long int exit_status;
2237 };
2238
2239 typedef struct _closed_pipes    Xpipe;
2240 typedef struct _closed_pipes*  pXpipe;
2241
2242 struct _closed_pipes {
2243     int             pid;            /* PID of subprocess */
2244     unsigned long   completion;     /* termination status of subprocess */
2245 };
2246 #define NKEEPCLOSED 50
2247 static Xpipe closed_list[NKEEPCLOSED];
2248 static int   closed_index = 0;
2249 static int   closed_num = 0;
2250
2251 #define RETRY_DELAY     "0 ::0.20"
2252 #define MAX_RETRY              50
2253
2254 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2255 static unsigned long mypid;
2256 static unsigned long delaytime[2];
2257
2258 static pInfo open_pipes = NULL;
2259 static $DESCRIPTOR(nl_desc, "NL:");
2260
2261 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2262
2263
2264
2265 static unsigned long int
2266 pipe_exit_routine(pTHX)
2267 {
2268     pInfo info;
2269     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2270     int sts, did_stuff, need_eof, j;
2271
2272     /*
2273         flush any pending i/o
2274     */
2275     info = open_pipes;
2276     while (info) {
2277         if (info->fp) {
2278            if (!info->useFILE)
2279                PerlIO_flush(info->fp);   /* first, flush data */
2280            else
2281                fflush((FILE *)info->fp);
2282         }
2283         info = info->next;
2284     }
2285
2286     /*
2287      next we try sending an EOF...ignore if doesn't work, make sure we
2288      don't hang
2289     */
2290     did_stuff = 0;
2291     info = open_pipes;
2292
2293     while (info) {
2294       int need_eof;
2295       _ckvmssts_noperl(sys$setast(0));
2296       if (info->in && !info->in->shut_on_empty) {
2297         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2298                           0, 0, 0, 0, 0, 0));
2299         info->waiting = 1;
2300         did_stuff = 1;
2301       }
2302       _ckvmssts_noperl(sys$setast(1));
2303       info = info->next;
2304     }
2305
2306     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2307
2308     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2309         int nwait = 0;
2310
2311         info = open_pipes;
2312         while (info) {
2313           _ckvmssts_noperl(sys$setast(0));
2314           if (info->waiting && info->done)
2315                 info->waiting = 0;
2316           nwait += info->waiting;
2317           _ckvmssts_noperl(sys$setast(1));
2318           info = info->next;
2319         }
2320         if (!nwait) break;
2321         sleep(1);
2322     }
2323
2324     did_stuff = 0;
2325     info = open_pipes;
2326     while (info) {
2327       _ckvmssts_noperl(sys$setast(0));
2328       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2329         sts = sys$forcex(&info->pid,0,&abort);
2330         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2331         did_stuff = 1;
2332       }
2333       _ckvmssts_noperl(sys$setast(1));
2334       info = info->next;
2335     }
2336
2337     /* again, wait for effect */
2338
2339     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2340         int nwait = 0;
2341
2342         info = open_pipes;
2343         while (info) {
2344           _ckvmssts_noperl(sys$setast(0));
2345           if (info->waiting && info->done)
2346                 info->waiting = 0;
2347           nwait += info->waiting;
2348           _ckvmssts_noperl(sys$setast(1));
2349           info = info->next;
2350         }
2351         if (!nwait) break;
2352         sleep(1);
2353     }
2354
2355     info = open_pipes;
2356     while (info) {
2357       _ckvmssts_noperl(sys$setast(0));
2358       if (!info->done) {  /* We tried to be nice . . . */
2359         sts = sys$delprc(&info->pid,0);
2360         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2361       }
2362       _ckvmssts_noperl(sys$setast(1));
2363       info = info->next;
2364     }
2365
2366     while(open_pipes) {
2367       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2368       else if (!(sts & 1)) retsts = sts;
2369     }
2370     return retsts;
2371 }
2372
2373 static struct exit_control_block pipe_exitblock =
2374        {(struct exit_control_block *) 0,
2375         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2376
2377 static void pipe_mbxtofd_ast(pPipe p);
2378 static void pipe_tochild1_ast(pPipe p);
2379 static void pipe_tochild2_ast(pPipe p);
2380
2381 static void
2382 popen_completion_ast(pInfo info)
2383 {
2384   pInfo i = open_pipes;
2385   int iss;
2386   int sts;
2387   pXpipe x;
2388
2389   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2390   closed_list[closed_index].pid = info->pid;
2391   closed_list[closed_index].completion = info->completion;
2392   closed_index++;
2393   if (closed_index == NKEEPCLOSED)
2394     closed_index = 0;
2395   closed_num++;
2396
2397   while (i) {
2398     if (i == info) break;
2399     i = i->next;
2400   }
2401   if (!i) return;       /* unlinked, probably freed too */
2402
2403   info->done = TRUE;
2404
2405 /*
2406     Writing to subprocess ...
2407             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2408
2409             chan_out may be waiting for "done" flag, or hung waiting
2410             for i/o completion to child...cancel the i/o.  This will
2411             put it into "snarf mode" (done but no EOF yet) that discards
2412             input.
2413
2414     Output from subprocess (stdout, stderr) needs to be flushed and
2415     shut down.   We try sending an EOF, but if the mbx is full the pipe
2416     routine should still catch the "shut_on_empty" flag, telling it to
2417     use immediate-style reads so that "mbx empty" -> EOF.
2418
2419
2420 */
2421   if (info->in && !info->in_done) {               /* only for mode=w */
2422         if (info->in->shut_on_empty && info->in->need_wake) {
2423             info->in->need_wake = FALSE;
2424             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2425         } else {
2426             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2427         }
2428   }
2429
2430   if (info->out && !info->out_done) {             /* were we also piping output? */
2431       info->out->shut_on_empty = TRUE;
2432       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2433       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2434       _ckvmssts_noperl(iss);
2435   }
2436
2437   if (info->err && !info->err_done) {        /* we were piping stderr */
2438         info->err->shut_on_empty = TRUE;
2439         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2440         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2441         _ckvmssts_noperl(iss);
2442   }
2443   _ckvmssts_noperl(sys$setef(pipe_ef));
2444
2445 }
2446
2447 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2448 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2449
2450 /*
2451     we actually differ from vmstrnenv since we use this to
2452     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2453     are pointing to the same thing
2454 */
2455
2456 static unsigned short
2457 popen_translate(pTHX_ char *logical, char *result)
2458 {
2459     int iss;
2460     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2461     $DESCRIPTOR(d_log,"");
2462     struct _il3 {
2463         unsigned short length;
2464         unsigned short code;
2465         char *         buffer_addr;
2466         unsigned short *retlenaddr;
2467     } itmlst[2];
2468     unsigned short l, ifi;
2469
2470     d_log.dsc$a_pointer = logical;
2471     d_log.dsc$w_length  = strlen(logical);
2472
2473     itmlst[0].code = LNM$_STRING;
2474     itmlst[0].length = 255;
2475     itmlst[0].buffer_addr = result;
2476     itmlst[0].retlenaddr = &l;
2477
2478     itmlst[1].code = 0;
2479     itmlst[1].length = 0;
2480     itmlst[1].buffer_addr = 0;
2481     itmlst[1].retlenaddr = 0;
2482
2483     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2484     if (iss == SS$_NOLOGNAM) {
2485         iss = SS$_NORMAL;
2486         l = 0;
2487     }
2488     if (!(iss&1)) lib$signal(iss);
2489     result[l] = '\0';
2490 /*
2491     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
2492     strip it off and return the ifi, if any
2493 */
2494     ifi  = 0;
2495     if (result[0] == 0x1b && result[1] == 0x00) {
2496         memmove(&ifi,result+2,2);
2497         strcpy(result,result+4);
2498     }
2499     return ifi;     /* this is the RMS internal file id */
2500 }
2501
2502 static void pipe_infromchild_ast(pPipe p);
2503
2504 /*
2505     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2506     inside an AST routine without worrying about reentrancy and which Perl
2507     memory allocator is being used.
2508
2509     We read data and queue up the buffers, then spit them out one at a
2510     time to the output mailbox when the output mailbox is ready for one.
2511
2512 */
2513 #define INITIAL_TOCHILDQUEUE  2
2514
2515 static pPipe
2516 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2517 {
2518     pPipe p;
2519     pCBuf b;
2520     char mbx1[64], mbx2[64];
2521     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2522                                       DSC$K_CLASS_S, mbx1},
2523                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2524                                       DSC$K_CLASS_S, mbx2};
2525     unsigned int dviitm = DVI$_DEVBUFSIZ;
2526     int j, n;
2527
2528     n = sizeof(Pipe);
2529     _ckvmssts(lib$get_vm(&n, &p));
2530
2531     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2532     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2533     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2534
2535     p->buf           = 0;
2536     p->shut_on_empty = FALSE;
2537     p->need_wake     = FALSE;
2538     p->type          = 0;
2539     p->retry         = 0;
2540     p->iosb.status   = SS$_NORMAL;
2541     p->iosb2.status  = SS$_NORMAL;
2542     p->free          = RQE_ZERO;
2543     p->wait          = RQE_ZERO;
2544     p->curr          = 0;
2545     p->curr2         = 0;
2546     p->info          = 0;
2547 #ifdef PERL_IMPLICIT_CONTEXT
2548     p->thx           = aTHX;
2549 #endif
2550
2551     n = sizeof(CBuf) + p->bufsize;
2552
2553     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2554         _ckvmssts(lib$get_vm(&n, &b));
2555         b->buf = (char *) b + sizeof(CBuf);
2556         _ckvmssts(lib$insqhi(b, &p->free));
2557     }
2558
2559     pipe_tochild2_ast(p);
2560     pipe_tochild1_ast(p);
2561     strcpy(wmbx, mbx1);
2562     strcpy(rmbx, mbx2);
2563     return p;
2564 }
2565
2566 /*  reads the MBX Perl is writing, and queues */
2567
2568 static void
2569 pipe_tochild1_ast(pPipe p)
2570 {
2571     pCBuf b = p->curr;
2572     int iss = p->iosb.status;
2573     int eof = (iss == SS$_ENDOFFILE);
2574     int sts;
2575 #ifdef PERL_IMPLICIT_CONTEXT
2576     pTHX = p->thx;
2577 #endif
2578
2579     if (p->retry) {
2580         if (eof) {
2581             p->shut_on_empty = TRUE;
2582             b->eof     = TRUE;
2583             _ckvmssts(sys$dassgn(p->chan_in));
2584         } else  {
2585             _ckvmssts(iss);
2586         }
2587
2588         b->eof  = eof;
2589         b->size = p->iosb.count;
2590         _ckvmssts(sts = lib$insqhi(b, &p->wait));
2591         if (p->need_wake) {
2592             p->need_wake = FALSE;
2593             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2594         }
2595     } else {
2596         p->retry = 1;   /* initial call */
2597     }
2598
2599     if (eof) {                  /* flush the free queue, return when done */
2600         int n = sizeof(CBuf) + p->bufsize;
2601         while (1) {
2602             iss = lib$remqti(&p->free, &b);
2603             if (iss == LIB$_QUEWASEMP) return;
2604             _ckvmssts(iss);
2605             _ckvmssts(lib$free_vm(&n, &b));
2606         }
2607     }
2608
2609     iss = lib$remqti(&p->free, &b);
2610     if (iss == LIB$_QUEWASEMP) {
2611         int n = sizeof(CBuf) + p->bufsize;
2612         _ckvmssts(lib$get_vm(&n, &b));
2613         b->buf = (char *) b + sizeof(CBuf);
2614     } else {
2615        _ckvmssts(iss);
2616     }
2617
2618     p->curr = b;
2619     iss = sys$qio(0,p->chan_in,
2620              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2621              &p->iosb,
2622              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2623     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2624     _ckvmssts(iss);
2625 }
2626
2627
2628 /* writes queued buffers to output, waits for each to complete before
2629    doing the next */
2630
2631 static void
2632 pipe_tochild2_ast(pPipe p)
2633 {
2634     pCBuf b = p->curr2;
2635     int iss = p->iosb2.status;
2636     int n = sizeof(CBuf) + p->bufsize;
2637     int done = (p->info && p->info->done) ||
2638               iss == SS$_CANCEL || iss == SS$_ABORT;
2639 #if defined(PERL_IMPLICIT_CONTEXT)
2640     pTHX = p->thx;
2641 #endif
2642
2643     do {
2644         if (p->type) {         /* type=1 has old buffer, dispose */
2645             if (p->shut_on_empty) {
2646                 _ckvmssts(lib$free_vm(&n, &b));
2647             } else {
2648                 _ckvmssts(lib$insqhi(b, &p->free));
2649             }
2650             p->type = 0;
2651         }
2652
2653         iss = lib$remqti(&p->wait, &b);
2654         if (iss == LIB$_QUEWASEMP) {
2655             if (p->shut_on_empty) {
2656                 if (done) {
2657                     _ckvmssts(sys$dassgn(p->chan_out));
2658                     *p->pipe_done = TRUE;
2659                     _ckvmssts(sys$setef(pipe_ef));
2660                 } else {
2661                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2662                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2663                 }
2664                 return;
2665             }
2666             p->need_wake = TRUE;
2667             return;
2668         }
2669         _ckvmssts(iss);
2670         p->type = 1;
2671     } while (done);
2672
2673
2674     p->curr2 = b;
2675     if (b->eof) {
2676         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2677             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2678     } else {
2679         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2680             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2681     }
2682
2683     return;
2684
2685 }
2686
2687
2688 static pPipe
2689 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2690 {
2691     pPipe p;
2692     char mbx1[64], mbx2[64];
2693     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2694                                       DSC$K_CLASS_S, mbx1},
2695                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2696                                       DSC$K_CLASS_S, mbx2};
2697     unsigned int dviitm = DVI$_DEVBUFSIZ;
2698
2699     int n = sizeof(Pipe);
2700     _ckvmssts(lib$get_vm(&n, &p));
2701     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2702     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2703
2704     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2705     n = p->bufsize * sizeof(char);
2706     _ckvmssts(lib$get_vm(&n, &p->buf));
2707     p->shut_on_empty = FALSE;
2708     p->info   = 0;
2709     p->type   = 0;
2710     p->iosb.status = SS$_NORMAL;
2711 #if defined(PERL_IMPLICIT_CONTEXT)
2712     p->thx = aTHX;
2713 #endif
2714     pipe_infromchild_ast(p);
2715
2716     strcpy(wmbx, mbx1);
2717     strcpy(rmbx, mbx2);
2718     return p;
2719 }
2720
2721 static void
2722 pipe_infromchild_ast(pPipe p)
2723 {
2724     int iss = p->iosb.status;
2725     int eof = (iss == SS$_ENDOFFILE);
2726     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2727     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2728 #if defined(PERL_IMPLICIT_CONTEXT)
2729     pTHX = p->thx;
2730 #endif
2731
2732     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
2733         _ckvmssts(sys$dassgn(p->chan_out));
2734         p->chan_out = 0;
2735     }
2736
2737     /* read completed:
2738             input shutdown if EOF from self (done or shut_on_empty)
2739             output shutdown if closing flag set (my_pclose)
2740             send data/eof from child or eof from self
2741             otherwise, re-read (snarf of data from child)
2742     */
2743
2744     if (p->type == 1) {
2745         p->type = 0;
2746         if (myeof && p->chan_in) {                  /* input shutdown */
2747             _ckvmssts(sys$dassgn(p->chan_in));
2748             p->chan_in = 0;
2749         }
2750
2751         if (p->chan_out) {
2752             if (myeof || kideof) {      /* pass EOF to parent */
2753                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2754                               pipe_infromchild_ast, p,
2755                               0, 0, 0, 0, 0, 0));
2756                 return;
2757             } else if (eof) {       /* eat EOF --- fall through to read*/
2758
2759             } else {                /* transmit data */
2760                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2761                               pipe_infromchild_ast,p,
2762                               p->buf, p->iosb.count, 0, 0, 0, 0));
2763                 return;
2764             }
2765         }
2766     }
2767
2768     /*  everything shut? flag as done */
2769
2770     if (!p->chan_in && !p->chan_out) {
2771         *p->pipe_done = TRUE;
2772         _ckvmssts(sys$setef(pipe_ef));
2773         return;
2774     }
2775
2776     /* write completed (or read, if snarfing from child)
2777             if still have input active,
2778                queue read...immediate mode if shut_on_empty so we get EOF if empty
2779             otherwise,
2780                check if Perl reading, generate EOFs as needed
2781     */
2782
2783     if (p->type == 0) {
2784         p->type = 1;
2785         if (p->chan_in) {
2786             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2787                           pipe_infromchild_ast,p,
2788                           p->buf, p->bufsize, 0, 0, 0, 0);
2789             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2790             _ckvmssts(iss);
2791         } else {           /* send EOFs for extra reads */
2792             p->iosb.status = SS$_ENDOFFILE;
2793             p->iosb.dvispec = 0;
2794             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2795                       0, 0, 0,
2796                       pipe_infromchild_ast, p, 0, 0, 0, 0));
2797         }
2798     }
2799 }
2800
2801 static pPipe
2802 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2803 {
2804     pPipe p;
2805     char mbx[64];
2806     unsigned long dviitm = DVI$_DEVBUFSIZ;
2807     struct stat s;
2808     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2809                                       DSC$K_CLASS_S, mbx};
2810     int n = sizeof(Pipe);
2811
2812     /* things like terminals and mbx's don't need this filter */
2813     if (fd && fstat(fd,&s) == 0) {
2814         unsigned long dviitm = DVI$_DEVCHAR, devchar;
2815         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2816                                          DSC$K_CLASS_S, s.st_dev};
2817
2818         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2819         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
2820             strcpy(out, s.st_dev);
2821             return 0;
2822         }
2823     }
2824
2825     _ckvmssts(lib$get_vm(&n, &p));
2826     p->fd_out = dup(fd);
2827     create_mbx(aTHX_ &p->chan_in, &d_mbx);
2828     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2829     n = (p->bufsize+1) * sizeof(char);
2830     _ckvmssts(lib$get_vm(&n, &p->buf));
2831     p->shut_on_empty = FALSE;
2832     p->retry = 0;
2833     p->info  = 0;
2834     strcpy(out, mbx);
2835
2836     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2837                   pipe_mbxtofd_ast, p,
2838                   p->buf, p->bufsize, 0, 0, 0, 0));
2839
2840     return p;
2841 }
2842
2843 static void
2844 pipe_mbxtofd_ast(pPipe p)
2845 {
2846     int iss = p->iosb.status;
2847     int done = p->info->done;
2848     int iss2;
2849     int eof = (iss == SS$_ENDOFFILE);
2850     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2851     int err = !(iss&1) && !eof;
2852 #if defined(PERL_IMPLICIT_CONTEXT)
2853     pTHX = p->thx;
2854 #endif
2855
2856     if (done && myeof) {               /* end piping */
2857         close(p->fd_out);
2858         sys$dassgn(p->chan_in);
2859         *p->pipe_done = TRUE;
2860         _ckvmssts(sys$setef(pipe_ef));
2861         return;
2862     }
2863
2864     if (!err && !eof) {             /* good data to send to file */
2865         p->buf[p->iosb.count] = '\n';
2866         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2867         if (iss2 < 0) {
2868             p->retry++;
2869             if (p->retry < MAX_RETRY) {
2870                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2871                 return;
2872             }
2873         }
2874         p->retry = 0;
2875     } else if (err) {
2876         _ckvmssts(iss);
2877     }
2878
2879
2880     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2881           pipe_mbxtofd_ast, p,
2882           p->buf, p->bufsize, 0, 0, 0, 0);
2883     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2884     _ckvmssts(iss);
2885 }
2886
2887
2888 typedef struct _pipeloc     PLOC;
2889 typedef struct _pipeloc*   pPLOC;
2890
2891 struct _pipeloc {
2892     pPLOC   next;
2893     char    dir[NAM$C_MAXRSS+1];
2894 };
2895 static pPLOC  head_PLOC = 0;
2896
2897 void
2898 free_pipelocs(pTHX_ void *head)
2899 {
2900     pPLOC p, pnext;
2901     pPLOC *pHead = (pPLOC *)head;
2902
2903     p = *pHead;
2904     while (p) {
2905         pnext = p->next;
2906         PerlMem_free(p);
2907         p = pnext;
2908     }
2909     *pHead = 0;
2910 }
2911
2912 static void
2913 store_pipelocs(pTHX)
2914 {
2915     int    i;
2916     pPLOC  p;
2917     AV    *av = 0;
2918     SV    *dirsv;
2919     GV    *gv;
2920     char  *dir, *x;
2921     char  *unixdir;
2922     char  temp[NAM$C_MAXRSS+1];
2923     STRLEN n_a;
2924
2925     if (head_PLOC)
2926         free_pipelocs(aTHX_ &head_PLOC);
2927
2928 /*  the . directory from @INC comes last */
2929
2930     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2931     p->next = head_PLOC;
2932     head_PLOC = p;
2933     strcpy(p->dir,"./");
2934
2935 /*  get the directory from $^X */
2936
2937 #ifdef PERL_IMPLICIT_CONTEXT
2938     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2939 #else
2940     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2941 #endif
2942         strcpy(temp, PL_origargv[0]);
2943         x = strrchr(temp,']');
2944         if (x == NULL) {
2945         x = strrchr(temp,'>');
2946           if (x == NULL) {
2947             /* It could be a UNIX path */
2948             x = strrchr(temp,'/');
2949           }
2950         }
2951         if (x)
2952           x[1] = '\0';
2953         else {
2954           /* Got a bare name, so use default directory */
2955           temp[0] = '.';
2956           temp[1] = '\0';
2957         }
2958
2959         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2960             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2961             p->next = head_PLOC;
2962             head_PLOC = p;
2963             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2964             p->dir[NAM$C_MAXRSS] = '\0';
2965         }
2966     }
2967
2968 /*  reverse order of @INC entries, skip "." since entered above */
2969
2970 #ifdef PERL_IMPLICIT_CONTEXT
2971     if (aTHX)
2972 #endif
2973     if (PL_incgv) av = GvAVn(PL_incgv);
2974
2975     for (i = 0; av && i <= AvFILL(av); i++) {
2976         dirsv = *av_fetch(av,i,TRUE);
2977
2978         if (SvROK(dirsv)) continue;
2979         dir = SvPVx(dirsv,n_a);
2980         if (strcmp(dir,".") == 0) continue;
2981         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2982             continue;
2983
2984         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2985         p->next = head_PLOC;
2986         head_PLOC = p;
2987         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2988         p->dir[NAM$C_MAXRSS] = '\0';
2989     }
2990
2991 /* most likely spot (ARCHLIB) put first in the list */
2992
2993 #ifdef ARCHLIB_EXP
2994     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2995         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2996         p->next = head_PLOC;
2997         head_PLOC = p;
2998         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2999         p->dir[NAM$C_MAXRSS] = '\0';
3000     }
3001 #endif
3002 }
3003
3004
3005 static char *
3006 find_vmspipe(pTHX)
3007 {
3008     static int   vmspipe_file_status = 0;
3009     static char  vmspipe_file[NAM$C_MAXRSS+1];
3010
3011     /* already found? Check and use ... need read+execute permission */
3012
3013     if (vmspipe_file_status == 1) {
3014         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3015          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3016             return vmspipe_file;
3017         }
3018         vmspipe_file_status = 0;
3019     }
3020
3021     /* scan through stored @INC, $^X */
3022
3023     if (vmspipe_file_status == 0) {
3024         char file[NAM$C_MAXRSS+1];
3025         pPLOC  p = head_PLOC;
3026
3027         while (p) {
3028             strcpy(file, p->dir);
3029             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3030             file[NAM$C_MAXRSS] = '\0';
3031             p = p->next;
3032
3033             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3034
3035             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3036              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3037                 vmspipe_file_status = 1;
3038                 return vmspipe_file;
3039             }
3040         }
3041         vmspipe_file_status = -1;   /* failed, use tempfiles */
3042     }
3043
3044     return 0;
3045 }
3046
3047 static FILE *
3048 vmspipe_tempfile(pTHX)
3049 {
3050     char file[NAM$C_MAXRSS+1];
3051     FILE *fp;
3052     static int index = 0;
3053     Stat_t s0, s1;
3054     int cmp_result;
3055
3056     /* create a tempfile */
3057
3058     /* we can't go from   W, shr=get to  R, shr=get without
3059        an intermediate vulnerable state, so don't bother trying...
3060
3061        and lib$spawn doesn't shr=put, so have to close the write
3062
3063        So... match up the creation date/time and the FID to
3064        make sure we're dealing with the same file
3065
3066     */
3067
3068     index++;
3069     if (!decc_filename_unix_only) {
3070       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3071       fp = fopen(file,"w");
3072       if (!fp) {
3073         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3074         fp = fopen(file,"w");
3075         if (!fp) {
3076             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3077             fp = fopen(file,"w");
3078         }
3079       }
3080      }
3081      else {
3082       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3083       fp = fopen(file,"w");
3084       if (!fp) {
3085         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3086         fp = fopen(file,"w");
3087         if (!fp) {
3088           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3089           fp = fopen(file,"w");
3090         }
3091       }
3092     }
3093     if (!fp) return 0;  /* we're hosed */
3094
3095     fprintf(fp,"$! 'f$verify(0)'\n");
3096     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3097     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3098     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3099     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3100     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3101     fprintf(fp,"$ perl_del    = \"delete\"\n");
3102     fprintf(fp,"$ pif         = \"if\"\n");
3103     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3104     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3105     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3106     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3107     fprintf(fp,"$!  --- build command line to get max possible length\n");
3108     fprintf(fp,"$c=perl_popen_cmd0\n");
3109     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3110     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3111     fprintf(fp,"$x=perl_popen_cmd3\n");
3112     fprintf(fp,"$c=c+x\n");
3113     fprintf(fp,"$ perl_on\n");
3114     fprintf(fp,"$ 'c'\n");
3115     fprintf(fp,"$ perl_status = $STATUS\n");
3116     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3117     fprintf(fp,"$ perl_exit 'perl_status'\n");
3118     fsync(fileno(fp));
3119
3120     fgetname(fp, file, 1);
3121     fstat(fileno(fp), (struct stat *)&s0);
3122     fclose(fp);
3123
3124     if (decc_filename_unix_only)
3125         do_tounixspec(file, file, 0);
3126     fp = fopen(file,"r","shr=get");
3127     if (!fp) return 0;
3128     fstat(fileno(fp), (struct stat *)&s1);
3129
3130     #if defined(_USE_STD_STAT)
3131       cmp_result = s0.crtl_stat.st_ino != s1.crtl_stat.st_ino;
3132     #else
3133       cmp_result = memcmp(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino, 6);
3134     #endif
3135     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3136         fclose(fp);
3137         return 0;
3138     }
3139
3140     return fp;
3141 }
3142
3143
3144
3145 static PerlIO *
3146 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3147 {
3148     static int handler_set_up = FALSE;
3149     unsigned long int sts, flags = CLI$M_NOWAIT;
3150     /* The use of a GLOBAL table (as was done previously) rendered
3151      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3152      * environment.  Hence we've switched to LOCAL symbol table.
3153      */
3154     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3155     int j, wait = 0, n;
3156     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3157     char in[512], out[512], err[512], mbx[512];
3158     FILE *tpipe = 0;
3159     char tfilebuf[NAM$C_MAXRSS+1];
3160     pInfo info = NULL;
3161     char cmd_sym_name[20];
3162     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3163                                       DSC$K_CLASS_S, symbol};
3164     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3165                                       DSC$K_CLASS_S, 0};
3166     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3167                                       DSC$K_CLASS_S, cmd_sym_name};
3168     struct dsc$descriptor_s *vmscmd;
3169     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3170     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3171     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3172
3173     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3174
3175     /* once-per-program initialization...
3176        note that the SETAST calls and the dual test of pipe_ef
3177        makes sure that only the FIRST thread through here does
3178        the initialization...all other threads wait until it's
3179        done.
3180
3181        Yeah, uglier than a pthread call, it's got all the stuff inline
3182        rather than in a separate routine.
3183     */
3184
3185     if (!pipe_ef) {
3186         _ckvmssts(sys$setast(0));
3187         if (!pipe_ef) {
3188             unsigned long int pidcode = JPI$_PID;
3189             $DESCRIPTOR(d_delay, RETRY_DELAY);
3190             _ckvmssts(lib$get_ef(&pipe_ef));
3191             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3192             _ckvmssts(sys$bintim(&d_delay, delaytime));
3193         }
3194         if (!handler_set_up) {
3195           _ckvmssts(sys$dclexh(&pipe_exitblock));
3196           handler_set_up = TRUE;
3197         }
3198         _ckvmssts(sys$setast(1));
3199     }
3200
3201     /* see if we can find a VMSPIPE.COM */
3202
3203     tfilebuf[0] = '@';
3204     vmspipe = find_vmspipe(aTHX);
3205     if (vmspipe) {
3206         strcpy(tfilebuf+1,vmspipe);
3207     } else {        /* uh, oh...we're in tempfile hell */
3208         tpipe = vmspipe_tempfile(aTHX);
3209         if (!tpipe) {       /* a fish popular in Boston */
3210             if (ckWARN(WARN_PIPE)) {
3211                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3212             }
3213         return Nullfp;
3214         }
3215         fgetname(tpipe,tfilebuf+1,1);
3216     }
3217     vmspipedsc.dsc$a_pointer = tfilebuf;
3218     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3219
3220     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3221     if (!(sts & 1)) {
3222       switch (sts) {
3223         case RMS$_FNF:  case RMS$_DNF:
3224           set_errno(ENOENT); break;
3225         case RMS$_DIR:
3226           set_errno(ENOTDIR); break;
3227         case RMS$_DEV:
3228           set_errno(ENODEV); break;
3229         case RMS$_PRV:
3230           set_errno(EACCES); break;
3231         case RMS$_SYN:
3232           set_errno(EINVAL); break;
3233         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3234           set_errno(E2BIG); break;
3235         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3236           _ckvmssts(sts); /* fall through */
3237         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3238           set_errno(EVMSERR);
3239       }
3240       set_vaxc_errno(sts);
3241       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3242         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3243       }
3244       *psts = sts;
3245       return Nullfp;
3246     }
3247     n = sizeof(Info);
3248     _ckvmssts(lib$get_vm(&n, &info));
3249
3250     strcpy(mode,in_mode);
3251     info->mode = *mode;
3252     info->done = FALSE;
3253     info->completion = 0;
3254     info->closing    = FALSE;
3255     info->in         = 0;
3256     info->out        = 0;
3257     info->err        = 0;
3258     info->fp         = Nullfp;
3259     info->useFILE    = 0;
3260     info->waiting    = 0;
3261     info->in_done    = TRUE;
3262     info->out_done   = TRUE;
3263     info->err_done   = TRUE;
3264     in[0] = out[0] = err[0] = '\0';
3265
3266     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3267         info->useFILE = 1;
3268         strcpy(p,p+1);
3269     }
3270     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3271         wait = 1;
3272         strcpy(p,p+1);
3273     }
3274
3275     if (*mode == 'r') {             /* piping from subroutine */
3276
3277         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3278         if (info->out) {
3279             info->out->pipe_done = &info->out_done;
3280             info->out_done = FALSE;
3281             info->out->info = info;
3282         }
3283         if (!info->useFILE) {
3284         info->fp  = PerlIO_open(mbx, mode);
3285         } else {
3286             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3287             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3288         }
3289
3290         if (!info->fp && info->out) {
3291             sys$cancel(info->out->chan_out);
3292
3293             while (!info->out_done) {
3294                 int done;
3295                 _ckvmssts(sys$setast(0));
3296                 done = info->out_done;
3297                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3298                 _ckvmssts(sys$setast(1));
3299                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3300             }
3301
3302             if (info->out->buf) {
3303                 n = info->out->bufsize * sizeof(char);
3304                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3305             }
3306             n = sizeof(Pipe);
3307             _ckvmssts(lib$free_vm(&n, &info->out));
3308             n = sizeof(Info);
3309             _ckvmssts(lib$free_vm(&n, &info));
3310             *psts = RMS$_FNF;
3311             return Nullfp;
3312         }
3313
3314         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3315         if (info->err) {
3316             info->err->pipe_done = &info->err_done;
3317             info->err_done = FALSE;
3318             info->err->info = info;
3319         }
3320
3321     } else if (*mode == 'w') {      /* piping to subroutine */
3322
3323         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3324         if (info->out) {
3325             info->out->pipe_done = &info->out_done;
3326             info->out_done = FALSE;
3327             info->out->info = info;
3328         }
3329
3330         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3331         if (info->err) {
3332             info->err->pipe_done = &info->err_done;
3333             info->err_done = FALSE;
3334             info->err->info = info;
3335         }
3336
3337         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3338         if (!info->useFILE) {
3339             info->fp  = PerlIO_open(mbx, mode);
3340         } else {
3341             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3342             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3343         }
3344
3345         if (info->in) {
3346             info->in->pipe_done = &info->in_done;
3347             info->in_done = FALSE;
3348             info->in->info = info;
3349         }
3350
3351         /* error cleanup */
3352         if (!info->fp && info->in) {
3353             info->done = TRUE;
3354             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3355                               0, 0, 0, 0, 0, 0, 0, 0));
3356
3357             while (!info->in_done) {
3358                 int done;
3359                 _ckvmssts(sys$setast(0));
3360                 done = info->in_done;
3361                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3362                 _ckvmssts(sys$setast(1));
3363                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3364             }
3365
3366             if (info->in->buf) {
3367                 n = info->in->bufsize * sizeof(char);
3368                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3369             }
3370             n = sizeof(Pipe);
3371             _ckvmssts(lib$free_vm(&n, &info->in));
3372             n = sizeof(Info);
3373             _ckvmssts(lib$free_vm(&n, &info));
3374             *psts = RMS$_FNF;
3375             return Nullfp;
3376         }
3377
3378
3379     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3380         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3381         if (info->out) {
3382             info->out->pipe_done = &info->out_done;
3383             info->out_done = FALSE;
3384             info->out->info = info;
3385         }
3386
3387         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3388         if (info->err) {
3389             info->err->pipe_done = &info->err_done;
3390             info->err_done = FALSE;
3391             info->err->info = info;
3392         }
3393     }
3394
3395     symbol[MAX_DCL_SYMBOL] = '\0';
3396
3397     strncpy(symbol, in, MAX_DCL_SYMBOL);
3398     d_symbol.dsc$w_length = strlen(symbol);
3399     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3400
3401     strncpy(symbol, err, MAX_DCL_SYMBOL);
3402     d_symbol.dsc$w_length = strlen(symbol);
3403     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3404
3405     strncpy(symbol, out, MAX_DCL_SYMBOL);
3406     d_symbol.dsc$w_length = strlen(symbol);
3407     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3408
3409     p = vmscmd->dsc$a_pointer;
3410     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
3411     if (*p == '$') p++;                         /* remove leading $ */
3412     while (*p == ' ' || *p == '\t') p++;
3413
3414     for (j = 0; j < 4; j++) {
3415         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3416         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3417
3418     strncpy(symbol, p, MAX_DCL_SYMBOL);
3419     d_symbol.dsc$w_length = strlen(symbol);
3420     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3421
3422         if (strlen(p) > MAX_DCL_SYMBOL) {
3423             p += MAX_DCL_SYMBOL;
3424         } else {
3425             p += strlen(p);
3426         }
3427     }
3428     _ckvmssts(sys$setast(0));
3429     info->next=open_pipes;  /* prepend to list */
3430     open_pipes=info;
3431     _ckvmssts(sys$setast(1));
3432     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3433      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
3434      * have SYS$COMMAND if we need it.
3435      */
3436     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3437                       0, &info->pid, &info->completion,
3438                       0, popen_completion_ast,info,0,0,0));
3439
3440     /* if we were using a tempfile, close it now */
3441
3442     if (tpipe) fclose(tpipe);
3443
3444     /* once the subprocess is spawned, it has copied the symbols and
3445        we can get rid of ours */
3446
3447     for (j = 0; j < 4; j++) {
3448         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3449         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3450     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3451     }
3452     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
3453     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3454     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3455     vms_execfree(vmscmd);
3456
3457 #ifdef PERL_IMPLICIT_CONTEXT
3458     if (aTHX)
3459 #endif
3460     PL_forkprocess = info->pid;
3461
3462     if (wait) {
3463          int done = 0;
3464          while (!done) {
3465              _ckvmssts(sys$setast(0));
3466              done = info->done;
3467              if (!done) _ckvmssts(sys$clref(pipe_ef));
3468              _ckvmssts(sys$setast(1));
3469              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3470          }
3471         *psts = info->completion;
3472 /* Caller thinks it is open and tries to close it. */
3473 /* This causes some problems, as it changes the error status */
3474 /*        my_pclose(info->fp); */
3475     } else {
3476         *psts = SS$_NORMAL;
3477     }
3478     return info->fp;
3479 }  /* end of safe_popen */
3480
3481
3482 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
3483 PerlIO *
3484 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3485 {
3486     int sts;
3487     TAINT_ENV();
3488     TAINT_PROPER("popen");
3489     PERL_FLUSHALL_FOR_CHILD;
3490     return safe_popen(aTHX_ cmd,mode,&sts);
3491 }
3492
3493 /*}}}*/
3494
3495 /*{{{  I32 my_pclose(PerlIO *fp)*/
3496 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3497 {
3498     pInfo info, last = NULL;
3499     unsigned long int retsts;
3500     int done, iss, n;
3501
3502     for (info = open_pipes; info != NULL; last = info, info = info->next)
3503         if (info->fp == fp) break;
3504
3505     if (info == NULL) {  /* no such pipe open */
3506       set_errno(ECHILD); /* quoth POSIX */
3507       set_vaxc_errno(SS$_NONEXPR);
3508       return -1;
3509     }
3510
3511     /* If we were writing to a subprocess, insure that someone reading from
3512      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
3513      * produce an EOF record in the mailbox.
3514      *
3515      *  well, at least sometimes it *does*, so we have to watch out for
3516      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
3517      */
3518      if (info->fp) {
3519         if (!info->useFILE)
3520             PerlIO_flush(info->fp);   /* first, flush data */
3521         else
3522             fflush((FILE *)info->fp);
3523     }
3524
3525     _ckvmssts(sys$setast(0));
3526      info->closing = TRUE;
3527      done = info->done && info->in_done && info->out_done && info->err_done;
3528      /* hanging on write to Perl's input? cancel it */
3529      if (info->mode == 'r' && info->out && !info->out_done) {
3530         if (info->out->chan_out) {
3531             _ckvmssts(sys$cancel(info->out->chan_out));
3532             if (!info->out->chan_in) {   /* EOF generation, need AST */
3533                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3534             }
3535         }
3536      }
3537      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
3538          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3539                            0, 0, 0, 0, 0, 0));
3540     _ckvmssts(sys$setast(1));
3541     if (info->fp) {
3542      if (!info->useFILE)
3543         PerlIO_close(info->fp);
3544      else
3545         fclose((FILE *)info->fp);
3546     }
3547      /*
3548         we have to wait until subprocess completes, but ALSO wait until all
3549         the i/o completes...otherwise we'll be freeing the "info" structure
3550         that the i/o ASTs could still be using...
3551      */
3552
3553      while (!done) {
3554          _ckvmssts(sys$setast(0));
3555          done = info->done && info->in_done && info->out_done && info->err_done;
3556          if (!done) _ckvmssts(sys$clref(pipe_ef));
3557          _ckvmssts(sys$setast(1));
3558          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3559      }
3560      retsts = info->completion;
3561
3562     /* remove from list of open pipes */
3563     _ckvmssts(sys$setast(0));
3564     if (last) last->next = info->next;
3565     else open_pipes = info->next;
3566     _ckvmssts(sys$setast(1));
3567
3568     /* free buffers and structures */
3569
3570     if (info->in) {
3571         if (info->in->buf) {
3572             n = info->in->bufsize * sizeof(char);
3573             _ckvmssts(lib$free_vm(&n, &info->in->buf));
3574         }
3575         n = sizeof(Pipe);
3576         _ckvmssts(lib$free_vm(&n, &info->in));
3577     }
3578     if (info->out) {
3579         if (info->out->buf) {
3580             n = info->out->bufsize * sizeof(char);
3581             _ckvmssts(lib$free_vm(&n, &info->out->buf));
3582         }
3583         n = sizeof(Pipe);
3584         _ckvmssts(lib$free_vm(&n, &info->out));
3585     }
3586     if (info->err) {
3587         if (info->err->buf) {
3588             n = info->err->bufsize * sizeof(char);
3589             _ckvmssts(lib$free_vm(&n, &info->err->buf));
3590         }
3591         n = sizeof(Pipe);
3592         _ckvmssts(lib$free_vm(&n, &info->err));
3593     }
3594     n = sizeof(Info);
3595     _ckvmssts(lib$free_vm(&n, &info));
3596
3597     return retsts;
3598
3599 }  /* end of my_pclose() */
3600
3601 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3602   /* Roll our own prototype because we want this regardless of whether
3603    * _VMS_WAIT is defined.
3604    */
3605   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3606 #endif
3607 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3608    created with popen(); otherwise partially emulate waitpid() unless
3609    we have a suitable one from the CRTL that came with VMS 7.2 and later.
3610    Also check processes not considered by the CRTL waitpid().
3611  */
3612 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3613 Pid_t
3614 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3615 {
3616     pInfo info;
3617     int done;
3618     int sts;
3619     int j;
3620
3621     if (statusp) *statusp = 0;
3622
3623     for (info = open_pipes; info != NULL; info = info->next)
3624         if (info->pid == pid) break;
3625
3626     if (info != NULL) {  /* we know about this child */
3627       while (!info->done) {
3628           _ckvmssts(sys$setast(0));
3629           done = info->done;
3630           if (!done) _ckvmssts(sys$clref(pipe_ef));
3631           _ckvmssts(sys$setast(1));
3632           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3633       }
3634
3635       if (statusp) *statusp = info->completion;
3636       return pid;
3637     }
3638
3639     /* child that already terminated? */
3640
3641     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3642         if (closed_list[j].pid == pid) {
3643             if (statusp) *statusp = closed_list[j].completion;
3644             return pid;
3645         }
3646     }
3647
3648     /* fall through if this child is not one of our own pipe children */
3649
3650 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3651
3652       /* waitpid() became available in the CRTL as of VMS 7.0, but only
3653        * in 7.2 did we get a version that fills in the VMS completion
3654        * status as Perl has always tried to do.
3655        */
3656
3657       sts = __vms_waitpid( pid, statusp, flags );
3658
3659       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3660          return sts;
3661
3662       /* If the real waitpid tells us the child does not exist, we
3663        * fall through here to implement waiting for a child that
3664        * was created by some means other than exec() (say, spawned
3665        * from DCL) or to wait for a process that is not a subprocess
3666        * of the current process.
3667        */
3668
3669 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3670
3671     {
3672       $DESCRIPTOR(intdsc,"0 00:00:01");
3673       unsigned long int ownercode = JPI$_OWNER, ownerpid;
3674       unsigned long int pidcode = JPI$_PID, mypid;
3675       unsigned long int interval[2];
3676       unsigned int jpi_iosb[2];
3677       struct itmlst_3 jpilist[2] = {
3678           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
3679           {                      0,         0,                 0, 0}
3680       };
3681
3682       if (pid <= 0) {
3683         /* Sorry folks, we don't presently implement rooting around for
3684            the first child we can find, and we definitely don't want to
3685            pass a pid of -1 to $getjpi, where it is a wildcard operation.
3686          */
3687         set_errno(ENOTSUP);
3688         return -1;
3689       }
3690
3691       /* Get the owner of the child so I can warn if it's not mine. If the
3692        * process doesn't exist or I don't have the privs to look at it,
3693        * I can go home early.
3694        */
3695       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3696       if (sts & 1) sts = jpi_iosb[0];
3697       if (!(sts & 1)) {
3698         switch (sts) {
3699             case SS$_NONEXPR:
3700                 set_errno(ECHILD);
3701                 break;
3702             case SS$_NOPRIV:
3703                 set_errno(EACCES);
3704                 break;
3705             default:
3706                 _ckvmssts(sts);
3707         }
3708         set_vaxc_errno(sts);
3709         return -1;
3710       }
3711
3712       if (ckWARN(WARN_EXEC)) {
3713         /* remind folks they are asking for non-standard waitpid behavior */
3714         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3715         if (ownerpid != mypid)
3716           Perl_warner(aTHX_ packWARN(WARN_EXEC),
3717                       "waitpid: process %x is not a child of process %x",
3718                       pid,mypid);
3719       }
3720
3721       /* simply check on it once a second until it's not there anymore. */
3722
3723       _ckvmssts(sys$bintim(&intdsc,interval));
3724       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3725             _ckvmssts(sys$schdwk(0,0,interval,0));
3726             _ckvmssts(sys$hiber());
3727       }
3728       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3729
3730       _ckvmssts(sts);
3731       return pid;
3732     }
3733 }  /* end of waitpid() */
3734 /*}}}*/
3735 /*}}}*/
3736 /*}}}*/
3737
3738 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3739 char *
3740 my_gconvert(double val, int ndig, int trail, char *buf)
3741 {
3742   static char __gcvtbuf[DBL_DIG+1];
3743   char *loc;
3744
3745   loc = buf ? buf : __gcvtbuf;
3746
3747 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
3748   if (val < 1) {
3749     sprintf(loc,"%.*g",ndig,val);
3750     return loc;
3751   }
3752 #endif
3753
3754   if (val) {
3755     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3756     return gcvt(val,ndig,loc);
3757   }
3758   else {
3759     loc[0] = '0'; loc[1] = '\0';
3760     return loc;
3761   }
3762
3763 }
3764 /*}}}*/
3765
3766 #if 1 /* defined(__VAX) || !defined(NAML$C_MAXRSS) */
3767 static int rms_free_search_context(struct FAB * fab)
3768 {
3769 struct NAM * nam;
3770
3771     nam = fab->fab$l_nam;
3772     nam->nam$b_nop |= NAM$M_SYNCHK;
3773     nam->nam$l_rlf = NULL;
3774     fab->fab$b_dns = 0;
3775     return sys$parse(fab, NULL, NULL);
3776 }
3777
3778 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
3779 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
3780 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
3781 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
3782 #define rms_nam_esll(nam) nam.nam$b_esl
3783 #define rms_nam_esl(nam) nam.nam$b_esl
3784 #define rms_nam_name(nam) nam.nam$l_name
3785 #define rms_nam_namel(nam) nam.nam$l_name
3786 #define rms_nam_type(nam) nam.nam$l_type
3787 #define rms_nam_typel(nam) nam.nam$l_type
3788 #define rms_nam_ver(nam) nam.nam$l_ver
3789 #define rms_nam_verl(nam) nam.nam$l_ver
3790 #define rms_nam_rsll(nam) nam.nam$b_rsl
3791 #define rms_nam_rsl(nam) nam.nam$b_rsl
3792 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
3793 #define rms_set_fna(fab, nam, name, size) \
3794         fab.fab$b_fns = size; fab.fab$l_fna = name;
3795 #define rms_get_fna(fab, nam) fab.fab$l_fna
3796 #define rms_set_dna(fab, nam, name, size) \
3797         fab.fab$b_dns = size; fab.fab$l_dna = name;
3798 #define rms_nam_dns(fab, nam) fab.fab$b_dns;
3799 #define rms_set_esa(fab, nam, name, size) \
3800         nam.nam$b_ess = size; nam.nam$l_esa = name;
3801 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3802         nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
3803 #define rms_set_rsa(nam, name, size) \
3804         nam.nam$l_rsa = name; nam.nam$b_rss = size;
3805 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3806         nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
3807
3808 #else
3809 static int rms_free_search_context(struct FAB * fab)
3810 {
3811 struct NAML * nam;
3812
3813     nam = fab->fab$l_naml;
3814     nam->naml$b_nop |= NAM$M_SYNCHK;
3815     nam->naml$l_rlf = NULL;
3816     nam->naml$l_long_defname_size = 0;
3817     fab->fab$b_dns = 0;
3818     return sys$parse(fab, NULL, NULL);
3819 }
3820
3821 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
3822 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
3823 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
3824 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
3825 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
3826 #define rms_nam_esl(nam) nam.naml$b_esl
3827 #define rms_nam_name(nam) nam.naml$l_name
3828 #define rms_nam_namel(nam) nam.naml$l_long_name
3829 #define rms_nam_type(nam) nam.naml$l_type
3830 #define rms_nam_typel(nam) nam.naml$l_long_type
3831 #define rms_nam_ver(nam) nam.naml$l_ver
3832 #define rms_nam_verl(nam) nam.naml$l_long_ver
3833 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
3834 #define rms_nam_rsl(nam) nam.naml$b_rsl
3835 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
3836 #define rms_set_fna(fab, nam, name, size) \
3837         fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
3838         nam.naml$l_long_filename_size = size; \
3839         nam.naml$l_long_filename = name
3840 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
3841 #define rms_set_dna(fab, nam, name, size) \
3842         fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
3843         nam.naml$l_long_defname_size = size; \
3844         nam.naml$l_long_defname = name
3845 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
3846 #define rms_set_esa(fab, nam, name, size) \
3847         nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
3848         nam.naml$l_long_expand_alloc = size; \
3849         nam.naml$l_long_expand = name
3850 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3851         nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
3852         nam.naml$l_long_expand = l_name; \
3853         nam.naml$l_long_expand_alloc = l_size;
3854 #define rms_set_rsa(nam, name, size) \
3855         nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
3856         nam.naml$l_long_result = name; \
3857         nam.naml$l_long_result_alloc = size;
3858 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3859         nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
3860         nam.naml$l_long_result = l_name; \
3861         nam.naml$l_long_result_alloc = l_size;
3862
3863 #endif
3864
3865
3866 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3867 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
3868  * to expand file specification.  Allows for a single default file
3869  * specification and a simple mask of options.  If outbuf is non-NULL,
3870  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3871  * the resultant file specification is placed.  If outbuf is NULL, the
3872  * resultant file specification is placed into a static buffer.
3873  * The third argument, if non-NULL, is taken to be a default file
3874  * specification string.  The fourth argument is unused at present.
3875  * rmesexpand() returns the address of the resultant string if
3876  * successful, and NULL on error.
3877  *
3878  * New functionality for previously unused opts value:
3879  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
3880  */
3881 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
3882
3883 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
3884 /* ODS-2 only version */
3885 static char *
3886 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3887 {
3888   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
3889   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
3890   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3891   struct FAB myfab = cc$rms_fab;
3892   struct NAM mynam = cc$rms_nam;
3893   STRLEN speclen;
3894   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3895   int sts;
3896
3897   if (!filespec || !*filespec) {
3898     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3899     return NULL;
3900   }
3901   if (!outbuf) {
3902     if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
3903     else    outbuf = __rmsexpand_retbuf;
3904   }
3905   isunix = is_unix_filespec(filespec);
3906   if (isunix) {
3907     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
3908         if (out)
3909            Safefree(out);
3910         return NULL;
3911     }
3912     filespec = vmsfspec;
3913   }
3914
3915   myfab.fab$l_fna = (char *)filespec;  /* cast ok for read only pointer */
3916   myfab.fab$b_fns = strlen(filespec);
3917   myfab.fab$l_nam = &mynam;
3918
3919   if (defspec && *defspec) {
3920     if (strchr(defspec,'/') != NULL) {
3921       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
3922         if (out)
3923            Safefree(out);
3924         return NULL;
3925       }
3926       defspec = tmpfspec;
3927     }
3928     myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
3929     myfab.fab$b_dns = strlen(defspec);
3930   }
3931
3932   mynam.nam$l_esa = esa;
3933   mynam.nam$b_ess = sizeof esa;
3934   mynam.nam$l_rsa = outbuf;
3935   mynam.nam$b_rss = NAM$C_MAXRSS;
3936
3937 #ifdef NAM$M_NO_SHORT_UPCASE
3938   if (decc_efs_case_preserve)
3939     mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3940 #endif
3941
3942   retsts = sys$parse(&myfab,0,0);
3943   if (!(retsts & 1)) {
3944     mynam.nam$b_nop |= NAM$M_SYNCHK;
3945     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
3946       retsts = sys$parse(&myfab,0,0);
3947       if (retsts & 1) goto expanded;
3948     }
3949     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3950     sts = sys$parse(&myfab,0,0);  /* Free search context */
3951     if (out) Safefree(out);
3952     set_vaxc_errno(retsts);
3953     if      (retsts == RMS$_PRV) set_errno(EACCES);
3954     else if (retsts == RMS$_DEV) set_errno(ENODEV);
3955     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3956     else                         set_errno(EVMSERR);
3957     return NULL;
3958   }
3959   retsts = sys$search(&myfab,0,0);
3960   if (!(retsts & 1) && retsts != RMS$_FNF) {
3961     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3962     myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
3963     if (out) Safefree(out);
3964     set_vaxc_errno(retsts);
3965     if      (retsts == RMS$_PRV) set_errno(EACCES);
3966     else                         set_errno(EVMSERR);
3967     return NULL;
3968   }
3969
3970   /* If the input filespec contained any lowercase characters,
3971    * downcase the result for compatibility with Unix-minded code. */
3972   expanded:
3973   if (!decc_efs_case_preserve) {
3974     for (out = myfab.fab$l_fna; *out; out++)
3975       if (islower(*out)) { haslower = 1; break; }
3976   }
3977   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3978   else                 { out = esa;    speclen = mynam.nam$b_esl; }
3979   /* Trim off null fields added by $PARSE
3980    * If type > 1 char, must have been specified in original or default spec
3981    * (not true for version; $SEARCH may have added version of existing file).
3982    */
3983   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3984   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3985              (mynam.nam$l_ver - mynam.nam$l_type == 1);
3986   if (trimver || trimtype) {
3987     if (defspec && *defspec) {
3988       char defesa[NAM$C_MAXRSS];
3989       struct FAB deffab = cc$rms_fab;
3990       struct NAM defnam = cc$rms_nam;
3991
3992       deffab.fab$l_nam = &defnam;
3993       /* cast below ok for read only pointer */
3994       deffab.fab$l_fna = (char *)defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
3995       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
3996       defnam.nam$b_nop = NAM$M_SYNCHK;
3997 #ifdef NAM$M_NO_SHORT_UPCASE
3998       if (decc_efs_case_preserve)
3999         defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4000 #endif
4001       if (sys$parse(&deffab,0,0) & 1) {
4002         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
4003         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4004       }
4005     }
4006     if (trimver) {
4007       if (*mynam.nam$l_ver != '\"')
4008         speclen = mynam.nam$l_ver - out;
4009     }
4010     if (trimtype) {
4011       /* If we didn't already trim version, copy down */
4012       if (speclen > mynam.nam$l_ver - out)
4013         memmove(mynam.nam$l_type, mynam.nam$l_ver,
4014                speclen - (mynam.nam$l_ver - out));
4015       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4016     }
4017   }
4018   /* If we just had a directory spec on input, $PARSE "helpfully"
4019    * adds an empty name and type for us */
4020   if (mynam.nam$l_name == mynam.nam$l_type &&
4021       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
4022       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4023     speclen = mynam.nam$l_name - out;
4024
4025   /* Posix format specifications must have matching quotes */
4026   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4027     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4028       out[speclen] = '\"';
4029       speclen++;
4030     }
4031   }
4032
4033   out[speclen] = '\0';
4034   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4035
4036   /* Have we been working with an expanded, but not resultant, spec? */
4037   /* Also, convert back to Unix syntax if necessary. */
4038   if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4039     isunix = 0;
4040
4041   if (!mynam.nam$b_rsl) {
4042     if (isunix) {
4043       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4044     }
4045     else strcpy(outbuf,esa);
4046   }
4047   else if (isunix) {
4048     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4049     strcpy(outbuf,tmpfspec);
4050   }
4051   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4052   mynam.nam$l_rsa = NULL;
4053   mynam.nam$b_rss = 0;
4054   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);  /* Free search context */
4055   return outbuf;
4056 }
4057 #else
4058 /* ODS-5 supporting routine */
4059 static char *
4060 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4061 {
4062   static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4063   char * vmsfspec, *tmpfspec;
4064   char * esa, *cp, *out = NULL;
4065   char * esal;
4066   char * outbufl;
4067   struct FAB myfab = cc$rms_fab;
4068   rms_setup_nam(mynam);
4069   STRLEN speclen;
4070   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4071   int sts;
4072
4073   if (!filespec || !*filespec) {
4074     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4075     return NULL;
4076   }
4077   if (!outbuf) {
4078     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4079     else    outbuf = __rmsexpand_retbuf;
4080   }
4081
4082   vmsfspec = NULL;
4083   tmpfspec = NULL;
4084   outbufl = NULL;
4085   isunix = is_unix_filespec(filespec);
4086   if (isunix) {
4087     Newx(vmsfspec, VMS_MAXRSS, char);
4088     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4089         Safefree(vmsfspec);
4090         if (out)
4091            Safefree(out);
4092         return NULL;
4093     }
4094     filespec = vmsfspec;
4095
4096      /* Unless we are forcing to VMS format, a UNIX input means
4097       * UNIX output, and that requires long names to be used
4098       */
4099     if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4100         opts |= PERL_RMSEXPAND_M_LONG;
4101     else {
4102         isunix = 0;
4103     }
4104   }
4105
4106   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4107   rms_bind_fab_nam(myfab, mynam);
4108
4109   if (defspec && *defspec) {
4110     int t_isunix;
4111     t_isunix = is_unix_filespec(defspec);
4112     if (t_isunix) {
4113       Newx(tmpfspec, VMS_MAXRSS, char);
4114       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4115         Safefree(tmpfspec);
4116         if (vmsfspec != NULL)
4117             Safefree(vmsfspec);
4118         if (out)
4119            Safefree(out);
4120         return NULL;
4121       }
4122       defspec = tmpfspec;
4123     }
4124     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4125   }
4126
4127   Newx(esa, NAM$C_MAXRSS + 1, char);
4128 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4129   Newx(esal, NAML$C_MAXRSS + 1, char);
4130 #endif
4131   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
4132
4133   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4134     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4135   }
4136   else {
4137 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4138     Newx(outbufl, VMS_MAXRSS, char);
4139     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4140 #else
4141     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4142 #endif
4143   }
4144
4145 #ifdef NAM$M_NO_SHORT_UPCASE
4146   if (decc_efs_case_preserve)
4147     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4148 #endif
4149
4150   /* First attempt to parse as an existing file */
4151   retsts = sys$parse(&myfab,0,0);
4152   if (!(retsts & STS$K_SUCCESS)) {
4153
4154     /* Could not find the file, try as syntax only if error is not fatal */
4155     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4156     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4157       retsts = sys$parse(&myfab,0,0);
4158       if (retsts & STS$K_SUCCESS) goto expanded;
4159     }
4160
4161      /* Still could not parse the file specification */
4162     /*----------------------------------------------*/
4163     sts = rms_free_search_context(&myfab); /* Free search context */
4164     if (out) Safefree(out);
4165     if (tmpfspec != NULL)
4166         Safefree(tmpfspec);
4167     if (vmsfspec != NULL)
4168         Safefree(vmsfspec);
4169     Safefree(esa);
4170     Safefree(esal);
4171     set_vaxc_errno(retsts);
4172     if      (retsts == RMS$_PRV) set_errno(EACCES);
4173     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4174     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4175     else                         set_errno(EVMSERR);
4176     return NULL;
4177   }
4178   retsts = sys$search(&myfab,0,0);
4179   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4180     sts = rms_free_search_context(&myfab); /* Free search context */
4181     if (out) Safefree(out);
4182     if (tmpfspec != NULL)
4183         Safefree(tmpfspec);
4184     if (vmsfspec != NULL)
4185         Safefree(vmsfspec);
4186     Safefree(esa);
4187     Safefree(esal);
4188     set_vaxc_errno(retsts);
4189     if      (retsts == RMS$_PRV) set_errno(EACCES);
4190     else                         set_errno(EVMSERR);
4191     return NULL;
4192   }
4193
4194   /* If the input filespec contained any lowercase characters,
4195    * downcase the result for compatibility with Unix-minded code. */
4196   expanded:
4197   if (!decc_efs_case_preserve) {
4198     for (out = rms_get_fna(myfab, mynam); *out; out++)
4199       if (islower(*out)) { haslower = 1; break; }
4200   }
4201
4202    /* Is a long or a short name expected */
4203   /*------------------------------------*/
4204   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4205     if (rms_nam_rsll(mynam)) {
4206         out = outbuf;
4207         speclen = rms_nam_rsll(mynam);
4208     }
4209     else {
4210         out = esal; /* Not esa */
4211         speclen = rms_nam_esll(mynam);
4212     }
4213   }
4214   else {
4215     if (rms_nam_rsl(mynam)) {
4216         out = outbuf;
4217         speclen = rms_nam_rsl(mynam);
4218     }
4219     else {
4220         out = esa; /* Not esal */
4221         speclen = rms_nam_esl(mynam);
4222     }
4223   }
4224   /* Trim off null fields added by $PARSE
4225    * If type > 1 char, must have been specified in original or default spec
4226    * (not true for version; $SEARCH may have added version of existing file).
4227    */
4228   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4229   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4230     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4231              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4232   }
4233   else {
4234     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4235              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4236   }
4237   if (trimver || trimtype) {
4238     if (defspec && *defspec) {
4239       char *defesal = NULL;
4240       Newx(defesal, NAML$C_MAXRSS + 1, char);
4241       if (defesal != NULL) {
4242         struct FAB deffab = cc$rms_fab;
4243         rms_setup_nam(defnam);
4244
4245         rms_bind_fab_nam(deffab, defnam);
4246
4247         /* Cast ok */
4248         rms_set_fna
4249             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4250
4251         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4252
4253         rms_set_nam_nop(defnam, 0);
4254         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4255 #ifdef NAM$M_NO_SHORT_UPCASE
4256         if (decc_efs_case_preserve)
4257           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4258 #endif
4259         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4260           if (trimver) {
4261              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4262           }
4263           if (trimtype) {
4264             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4265           }
4266         }
4267         Safefree(defesal);
4268       }
4269     }
4270     if (trimver) {
4271       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4272         if (*(rms_nam_verl(mynam)) != '\"')
4273           speclen = rms_nam_verl(mynam) - out;
4274       }
4275       else {
4276         if (*(rms_nam_ver(mynam)) != '\"')
4277           speclen = rms_nam_ver(mynam) - out;
4278       }
4279     }
4280     if (trimtype) {
4281       /* If we didn't already trim version, copy down */
4282       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4283         if (speclen > rms_nam_verl(mynam) - out)
4284           memmove
4285            (rms_nam_typel(mynam),
4286             rms_nam_verl(mynam),
4287             speclen - (rms_nam_verl(mynam) - out));
4288           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4289       }
4290       else {
4291         if (speclen > rms_nam_ver(mynam) - out)
4292           memmove
4293            (rms_nam_type(mynam),
4294             rms_nam_ver(mynam),
4295             speclen - (rms_nam_ver(mynam) - out));
4296           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4297       }
4298     }
4299   }
4300
4301    /* Done with these copies of the input files */
4302   /*-------------------------------------------*/
4303   if (vmsfspec != NULL)
4304         Safefree(vmsfspec);
4305   if (tmpfspec != NULL)
4306         Safefree(tmpfspec);
4307
4308   /* If we just had a directory spec on input, $PARSE "helpfully"
4309    * adds an empty name and type for us */
4310   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4311     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4312         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
4313         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4314       speclen = rms_nam_namel(mynam) - out;
4315   }
4316   else {
4317     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4318         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
4319         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4320       speclen = rms_nam_name(mynam) - out;
4321   }
4322
4323   /* Posix format specifications must have matching quotes */
4324   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4325     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4326       out[speclen] = '\"';
4327       speclen++;
4328     }
4329   }
4330   out[speclen] = '\0';
4331   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4332
4333   /* Have we been working with an expanded, but not resultant, spec? */
4334   /* Also, convert back to Unix syntax if necessary. */
4335
4336   if (!rms_nam_rsll(mynam)) {
4337     if (isunix) {
4338       if (do_tounixspec(esa,outbuf,0) == NULL) {
4339         Safefree(esal);
4340         Safefree(esa);
4341         return NULL;
4342       }
4343     }
4344     else strcpy(outbuf,esa);
4345   }
4346   else if (isunix) {
4347     Newx(tmpfspec, VMS_MAXRSS, char);
4348     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4349         Safefree(esa);
4350         Safefree(esal);
4351         Safefree(tmpfspec);
4352         return NULL;
4353     }
4354     strcpy(outbuf,tmpfspec);
4355     Safefree(tmpfspec);
4356   }
4357
4358   rms_set_rsal(mynam, NULL, 0, NULL, 0);
4359   sts = rms_free_search_context(&myfab); /* Free search context */
4360   Safefree(esa);
4361   Safefree(esal);
4362   return outbuf;
4363 }
4364 #endif
4365 /*}}}*/
4366 /* External entry points */
4367 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4368 { return do_rmsexpand(spec,buf,0,def,opt); }
4369 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4370 { return do_rmsexpand(spec,buf,1,def,opt); }
4371
4372
4373 /*
4374 ** The following routines are provided to make life easier when
4375 ** converting among VMS-style and Unix-style directory specifications.
4376 ** All will take input specifications in either VMS or Unix syntax. On
4377 ** failure, all return NULL.  If successful, the routines listed below
4378 ** return a pointer to a buffer containing the appropriately
4379 ** reformatted spec (and, therefore, subsequent calls to that routine
4380 ** will clobber the result), while the routines of the same names with
4381 ** a _ts suffix appended will return a pointer to a mallocd string
4382 ** containing the appropriately reformatted spec.
4383 ** In all cases, only explicit syntax is altered; no check is made that
4384 ** the resulting string is valid or that the directory in question
4385 ** actually exists.
4386 **
4387 **   fileify_dirspec() - convert a directory spec into the name of the
4388 **     directory file (i.e. what you can stat() to see if it's a dir).
4389 **     The style (VMS or Unix) of the result is the same as the style
4390 **     of the parameter passed in.
4391 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4392 **     what you prepend to a filename to indicate what directory it's in).
4393 **     The style (VMS or Unix) of the result is the same as the style
4394 **     of the parameter passed in.
4395 **   tounixpath() - convert a directory spec into a Unix-style path.
4396 **   tovmspath() - convert a directory spec into a VMS-style path.
4397 **   tounixspec() - convert any file spec into a Unix-style file spec.
4398 **   tovmsspec() - convert any file spec into a VMS-style spec.
4399 **
4400 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4401 ** Permission is given to distribute this code as part of the Perl
4402 ** standard distribution under the terms of the GNU General Public
4403 ** License or the Perl Artistic License.  Copies of each may be
4404 ** found in the Perl standard distribution.
4405  */
4406
4407 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4408 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4409 {
4410     static char __fileify_retbuf[VMS_MAXRSS];
4411     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4412     char *retspec, *cp1, *cp2, *lastdir;
4413     char *trndir, *vmsdir;
4414     unsigned short int trnlnm_iter_count;
4415     int sts;
4416
4417     if (!dir || !*dir) {
4418       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4419     }
4420     dirlen = strlen(dir);
4421     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4422     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4423       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4424         dir = "/sys$disk";
4425         dirlen = 9;
4426       }
4427       else
4428         dirlen = 1;
4429     }
4430     if (dirlen > (VMS_MAXRSS - 1)) {
4431       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4432       return NULL;
4433     }
4434     Newx(trndir, VMS_MAXRSS + 1, char);
4435     if (!strpbrk(dir+1,"/]>:")  &&
4436         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4437       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4438       trnlnm_iter_count = 0;
4439       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4440         trnlnm_iter_count++;
4441         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4442       }
4443       dirlen = strlen(trndir);
4444     }
4445     else {
4446       strncpy(trndir,dir,dirlen);
4447       trndir[dirlen] = '\0';
4448     }
4449
4450     /* At this point we are done with *dir and use *trndir which is a
4451      * copy that can be modified.  *dir must not be modified.
4452      */
4453
4454     /* If we were handed a rooted logical name or spec, treat it like a
4455      * simple directory, so that
4456      *    $ Define myroot dev:[dir.]
4457      *    ... do_fileify_dirspec("myroot",buf,1) ...
4458      * does something useful.
4459      */
4460     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4461       trndir[--dirlen] = '\0';
4462       trndir[dirlen-1] = ']';
4463     }
4464     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4465       trndir[--dirlen] = '\0';
4466       trndir[dirlen-1] = '>';
4467     }
4468
4469     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4470       /* If we've got an explicit filename, we can just shuffle the string. */
4471       if (*(cp1+1)) hasfilename = 1;
4472       /* Similarly, we can just back up a level if we've got multiple levels
4473          of explicit directories in a VMS spec which ends with directories. */
4474       else {
4475         for (cp2 = cp1; cp2 > trndir; cp2--) {
4476           if (*cp2 == '.') {
4477             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4478               *cp2 = *cp1; *cp1 = '\0';
4479               hasfilename = 1;
4480               break;
4481             }
4482           }
4483           if (*cp2 == '[' || *cp2 == '<') break;
4484         }
4485       }
4486     }
4487
4488     Newx(vmsdir, VMS_MAXRSS + 1, char);
4489     cp1 = strpbrk(trndir,"]:>");
4490     if (hasfilename || !cp1) { /* Unix-style path or filename */
4491       if (trndir[0] == '.') {
4492         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4493           Safefree(trndir);
4494           Safefree(vmsdir);
4495           return do_fileify_dirspec("[]",buf,ts);
4496         }
4497         else if (trndir[1] == '.' &&
4498                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4499           Safefree(trndir);
4500           Safefree(vmsdir);
4501           return do_fileify_dirspec("[-]",buf,ts);
4502         }
4503       }
4504       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4505         dirlen -= 1;                 /* to last element */
4506         lastdir = strrchr(trndir,'/');
4507       }
4508       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4509         /* If we have "/." or "/..", VMSify it and let the VMS code
4510          * below expand it, rather than repeating the code to handle
4511          * relative components of a filespec here */
4512         do {
4513           if (*(cp1+2) == '.') cp1++;
4514           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4515             char * ret_chr;
4516             if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4517                 Safefree(trndir);
4518                 Safefree(vmsdir);
4519                 return NULL;
4520             }
4521             if (strchr(vmsdir,'/') != NULL) {
4522               /* If do_tovmsspec() returned it, it must have VMS syntax
4523                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
4524                * the time to check this here only so we avoid a recursion
4525                * loop; otherwise, gigo.
4526                */
4527               Safefree(trndir);
4528               Safefree(vmsdir);
4529               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
4530               return NULL;
4531             }
4532             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4533                 Safefree(trndir);
4534                 Safefree(vmsdir);
4535                 return NULL;
4536             }
4537             ret_chr = do_tounixspec(trndir,buf,ts);
4538             Safefree(trndir);
4539             Safefree(vmsdir);
4540             return ret_chr;
4541           }
4542           cp1++;
4543         } while ((cp1 = strstr(cp1,"/.")) != NULL);
4544         lastdir = strrchr(trndir,'/');
4545       }
4546       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4547         char * ret_chr;
4548         /* Ditto for specs that end in an MFD -- let the VMS code
4549          * figure out whether it's a real device or a rooted logical. */
4550
4551         /* This should not happen any more.  Allowing the fake /000000
4552          * in a UNIX pathname causes all sorts of problems when trying
4553          * to run in UNIX emulation.  So the VMS to UNIX conversions
4554          * now remove the fake /000000 directories.
4555          */
4556
4557         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4558         if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4559             Safefree(trndir);
4560             Safefree(vmsdir);
4561             return NULL;
4562         }
4563         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4564             Safefree(trndir);
4565             Safefree(vmsdir);
4566             return NULL;
4567         }
4568         ret_chr = do_tounixspec(trndir,buf,ts);
4569         Safefree(trndir);
4570         Safefree(vmsdir);
4571         return ret_chr;
4572       }
4573       else {
4574
4575         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4576              !(lastdir = cp1 = strrchr(trndir,']')) &&
4577              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4578         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
4579           int ver; char *cp3;
4580
4581           /* For EFS or ODS-5 look for the last dot */
4582           if (decc_efs_charset) {
4583               cp2 = strrchr(cp1,'.');
4584           }
4585           if (vms_process_case_tolerant) {
4586               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4587                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4588                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4589                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4590                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4591                             (ver || *cp3)))))) {
4592                   Safefree(trndir);
4593                   Safefree(vmsdir);
4594                   set_errno(ENOTDIR);
4595                   set_vaxc_errno(RMS$_DIR);
4596                   return NULL;
4597               }
4598           }
4599           else {
4600               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4601                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4602                   !*(cp2+3) || *(cp2+3) != 'R' ||
4603                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4604                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4605                             (ver || *cp3)))))) {
4606                  Safefree(trndir);
4607                  Safefree(vmsdir);
4608                  set_errno(ENOTDIR);
4609                  set_vaxc_errno(RMS$_DIR);
4610                  return NULL;
4611               }
4612           }
4613           dirlen = cp2 - trndir;
4614         }
4615       }
4616
4617       retlen = dirlen + 6;
4618       if (buf) retspec = buf;
4619       else if (ts) Newx(retspec,retlen+1,char);
4620       else retspec = __fileify_retbuf;
4621       memcpy(retspec,trndir,dirlen);
4622       retspec[dirlen] = '\0';
4623
4624       /* We've picked up everything up to the directory file name.
4625          Now just add the type and version, and we're set. */
4626       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4627         strcat(retspec,".dir;1");
4628       else
4629         strcat(retspec,".DIR;1");
4630       Safefree(trndir);
4631       Safefree(vmsdir);
4632       return retspec;
4633     }
4634     else {  /* VMS-style directory spec */
4635
4636       char *esa, term, *cp;
4637       unsigned long int sts, cmplen, haslower = 0;
4638       unsigned int nam_fnb;
4639       char * nam_type;
4640       struct FAB dirfab = cc$rms_fab;
4641       rms_setup_nam(savnam);
4642       rms_setup_nam(dirnam);
4643
4644       Newx(esa, VMS_MAXRSS + 1, char);
4645       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4646       rms_bind_fab_nam(dirfab, dirnam);
4647       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4648       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4649 #ifdef NAM$M_NO_SHORT_UPCASE
4650       if (decc_efs_case_preserve)
4651         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4652 #endif
4653
4654       for (cp = trndir; *cp; cp++)
4655         if (islower(*cp)) { haslower = 1; break; }
4656       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4657         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4658           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4659           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4660         }
4661         if (!sts) {
4662           Safefree(esa);
4663           Safefree(trndir);
4664           Safefree(vmsdir);
4665           set_errno(EVMSERR);
4666           set_vaxc_errno(dirfab.fab$l_sts);
4667           return NULL;
4668         }
4669       }
4670       else {
4671         savnam = dirnam;
4672         /* Does the file really exist? */
4673         if (sys$search(&dirfab)& STS$K_SUCCESS) {
4674           /* Yes; fake the fnb bits so we'll check type below */
4675         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4676         }
4677         else { /* No; just work with potential name */
4678           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4679           else {
4680             Safefree(esa);
4681             Safefree(trndir);
4682             Safefree(vmsdir);
4683             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
4684             sts = rms_free_search_context(&dirfab);
4685             return NULL;
4686           }
4687         }
4688       }
4689       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4690         cp1 = strchr(esa,']');
4691         if (!cp1) cp1 = strchr(esa,'>');
4692         if (cp1) {  /* Should always be true */
4693           rms_nam_esll(dirnam) -= cp1 - esa - 1;
4694           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
4695         }
4696       }
4697       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
4698         /* Yep; check version while we're at it, if it's there. */
4699         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
4700         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
4701           /* Something other than .DIR[;1].  Bzzt. */
4702           sts = rms_free_search_context(&dirfab);
4703           Safefree(esa);
4704           Safefree(trndir);
4705           Safefree(vmsdir);
4706           set_errno(ENOTDIR);
4707           set_vaxc_errno(RMS$_DIR);
4708           return NULL;
4709         }
4710       }
4711       esa[rms_nam_esll(dirnam)] = '\0';
4712       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
4713         /* They provided at least the name; we added the type, if necessary, */
4714         if (buf) retspec = buf;                            /* in sys$parse() */
4715         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
4716         else retspec = __fileify_retbuf;
4717         strcpy(retspec,esa);
4718         sts = rms_free_search_context(&dirfab);
4719         Safefree(trndir);
4720         Safefree(esa);
4721         Safefree(vmsdir);
4722         return retspec;
4723       }
4724       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4725         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4726         *cp1 = '\0';
4727         rms_nam_esll(dirnam) -= 9;
4728       }
4729       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4730       if (cp1 == NULL) { /* should never happen */
4731         sts = rms_free_search_context(&dirfab);
4732         Safefree(trndir);
4733         Safefree(esa);
4734         Safefree(vmsdir);
4735         return NULL;
4736       }
4737       term = *cp1;
4738       *cp1 = '\0';
4739       retlen = strlen(esa);
4740       cp1 = strrchr(esa,'.');
4741       /* ODS-5 directory specifications can have extra "." in them. */
4742       while (cp1 != NULL) {
4743         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4744           break;
4745         else {
4746            cp1--;
4747            while ((cp1 > esa) && (*cp1 != '.'))
4748              cp1--;
4749         }
4750         if (cp1 == esa)
4751           cp1 = NULL;
4752       }
4753
4754       if ((cp1) != NULL) {
4755         /* There's more than one directory in the path.  Just roll back. */
4756         *cp1 = term;
4757         if (buf) retspec = buf;
4758         else if (ts) Newx(retspec,retlen+7,char);
4759         else retspec = __fileify_retbuf;
4760         strcpy(retspec,esa);
4761       }
4762       else {
4763         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
4764           /* Go back and expand rooted logical name */
4765           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
4766 #ifdef NAM$M_NO_SHORT_UPCASE
4767           if (decc_efs_case_preserve)
4768             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4769 #endif
4770           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
4771             sts = rms_free_search_context(&dirfab);
4772             Safefree(esa);
4773             Safefree(trndir);
4774             Safefree(vmsdir);
4775             set_errno(EVMSERR);
4776             set_vaxc_errno(dirfab.fab$l_sts);
4777             return NULL;
4778           }
4779           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
4780           if (buf) retspec = buf;
4781           else if (ts) Newx(retspec,retlen+16,char);
4782           else retspec = __fileify_retbuf;
4783           cp1 = strstr(esa,"][");
4784           if (!cp1) cp1 = strstr(esa,"]<");
4785           dirlen = cp1 - esa;
4786           memcpy(retspec,esa,dirlen);
4787           if (!strncmp(cp1+2,"000000]",7)) {
4788             retspec[dirlen-1] = '\0';
4789             /* Not full ODS-5, just extra dots in directories for now */
4790             cp1 = retspec + dirlen - 1;
4791             while (cp1 > retspec)
4792             {
4793               if (*cp1 == '[')
4794                 break;
4795               if (*cp1 == '.') {
4796                 if (*(cp1-1) != '^')
4797                   break;
4798               }
4799               cp1--;
4800             }
4801             if (*cp1 == '.') *cp1 = ']';
4802             else {
4803               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4804               memmove(cp1+1,"000000]",7);
4805             }
4806           }
4807           else {
4808             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
4809             retspec[retlen] = '\0';
4810             /* Convert last '.' to ']' */