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(sys$setast(0));
2296       if (info->in && !info->in->shut_on_empty) {
2297         _ckvmssts(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(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(sys$setast(0));
2314           if (info->waiting && info->done)
2315                 info->waiting = 0;
2316           nwait += info->waiting;
2317           _ckvmssts(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(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(sts);
2331         did_stuff = 1;
2332       }
2333       _ckvmssts(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(sys$setast(0));
2345           if (info->waiting && info->done)
2346                 info->waiting = 0;
2347           nwait += info->waiting;
2348           _ckvmssts(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(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(sts);
2361       }
2362       _ckvmssts(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     Newx(p, 1, Pipe);
2529
2530     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2531     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2532     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2533
2534     p->buf           = 0;
2535     p->shut_on_empty = FALSE;
2536     p->need_wake     = FALSE;
2537     p->type          = 0;
2538     p->retry         = 0;
2539     p->iosb.status   = SS$_NORMAL;
2540     p->iosb2.status  = SS$_NORMAL;
2541     p->free          = RQE_ZERO;
2542     p->wait          = RQE_ZERO;
2543     p->curr          = 0;
2544     p->curr2         = 0;
2545     p->info          = 0;
2546 #ifdef PERL_IMPLICIT_CONTEXT
2547     p->thx           = aTHX;
2548 #endif
2549
2550     n = sizeof(CBuf) + p->bufsize;
2551
2552     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2553         _ckvmssts(lib$get_vm(&n, &b));
2554         b->buf = (char *) b + sizeof(CBuf);
2555         _ckvmssts(lib$insqhi(b, &p->free));
2556     }
2557
2558     pipe_tochild2_ast(p);
2559     pipe_tochild1_ast(p);
2560     strcpy(wmbx, mbx1);
2561     strcpy(rmbx, mbx2);
2562     return p;
2563 }
2564
2565 /*  reads the MBX Perl is writing, and queues */
2566
2567 static void
2568 pipe_tochild1_ast(pPipe p)
2569 {
2570     pCBuf b = p->curr;
2571     int iss = p->iosb.status;
2572     int eof = (iss == SS$_ENDOFFILE);
2573     int sts;
2574 #ifdef PERL_IMPLICIT_CONTEXT
2575     pTHX = p->thx;
2576 #endif
2577
2578     if (p->retry) {
2579         if (eof) {
2580             p->shut_on_empty = TRUE;
2581             b->eof     = TRUE;
2582             _ckvmssts(sys$dassgn(p->chan_in));
2583         } else  {
2584             _ckvmssts(iss);
2585         }
2586
2587         b->eof  = eof;
2588         b->size = p->iosb.count;
2589         _ckvmssts(sts = lib$insqhi(b, &p->wait));
2590         if (p->need_wake) {
2591             p->need_wake = FALSE;
2592             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2593         }
2594     } else {
2595         p->retry = 1;   /* initial call */
2596     }
2597
2598     if (eof) {                  /* flush the free queue, return when done */
2599         int n = sizeof(CBuf) + p->bufsize;
2600         while (1) {
2601             iss = lib$remqti(&p->free, &b);
2602             if (iss == LIB$_QUEWASEMP) return;
2603             _ckvmssts(iss);
2604             _ckvmssts(lib$free_vm(&n, &b));
2605         }
2606     }
2607
2608     iss = lib$remqti(&p->free, &b);
2609     if (iss == LIB$_QUEWASEMP) {
2610         int n = sizeof(CBuf) + p->bufsize;
2611         _ckvmssts(lib$get_vm(&n, &b));
2612         b->buf = (char *) b + sizeof(CBuf);
2613     } else {
2614        _ckvmssts(iss);
2615     }
2616
2617     p->curr = b;
2618     iss = sys$qio(0,p->chan_in,
2619              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2620              &p->iosb,
2621              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2622     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2623     _ckvmssts(iss);
2624 }
2625
2626
2627 /* writes queued buffers to output, waits for each to complete before
2628    doing the next */
2629
2630 static void
2631 pipe_tochild2_ast(pPipe p)
2632 {
2633     pCBuf b = p->curr2;
2634     int iss = p->iosb2.status;
2635     int n = sizeof(CBuf) + p->bufsize;
2636     int done = (p->info && p->info->done) ||
2637               iss == SS$_CANCEL || iss == SS$_ABORT;
2638 #if defined(PERL_IMPLICIT_CONTEXT)
2639     pTHX = p->thx;
2640 #endif
2641
2642     do {
2643         if (p->type) {         /* type=1 has old buffer, dispose */
2644             if (p->shut_on_empty) {
2645                 _ckvmssts(lib$free_vm(&n, &b));
2646             } else {
2647                 _ckvmssts(lib$insqhi(b, &p->free));
2648             }
2649             p->type = 0;
2650         }
2651
2652         iss = lib$remqti(&p->wait, &b);
2653         if (iss == LIB$_QUEWASEMP) {
2654             if (p->shut_on_empty) {
2655                 if (done) {
2656                     _ckvmssts(sys$dassgn(p->chan_out));
2657                     *p->pipe_done = TRUE;
2658                     _ckvmssts(sys$setef(pipe_ef));
2659                 } else {
2660                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2661                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2662                 }
2663                 return;
2664             }
2665             p->need_wake = TRUE;
2666             return;
2667         }
2668         _ckvmssts(iss);
2669         p->type = 1;
2670     } while (done);
2671
2672
2673     p->curr2 = b;
2674     if (b->eof) {
2675         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2676             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2677     } else {
2678         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2679             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2680     }
2681
2682     return;
2683
2684 }
2685
2686
2687 static pPipe
2688 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2689 {
2690     pPipe p;
2691     char mbx1[64], mbx2[64];
2692     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2693                                       DSC$K_CLASS_S, mbx1},
2694                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2695                                       DSC$K_CLASS_S, mbx2};
2696     unsigned int dviitm = DVI$_DEVBUFSIZ;
2697
2698     Newx(p, 1, Pipe);
2699     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2700     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2701
2702     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2703     Newx(p->buf, p->bufsize, char);
2704     p->shut_on_empty = FALSE;
2705     p->info   = 0;
2706     p->type   = 0;
2707     p->iosb.status = SS$_NORMAL;
2708 #if defined(PERL_IMPLICIT_CONTEXT)
2709     p->thx = aTHX;
2710 #endif
2711     pipe_infromchild_ast(p);
2712
2713     strcpy(wmbx, mbx1);
2714     strcpy(rmbx, mbx2);
2715     return p;
2716 }
2717
2718 static void
2719 pipe_infromchild_ast(pPipe p)
2720 {
2721     int iss = p->iosb.status;
2722     int eof = (iss == SS$_ENDOFFILE);
2723     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2724     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2725 #if defined(PERL_IMPLICIT_CONTEXT)
2726     pTHX = p->thx;
2727 #endif
2728
2729     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
2730         _ckvmssts(sys$dassgn(p->chan_out));
2731         p->chan_out = 0;
2732     }
2733
2734     /* read completed:
2735             input shutdown if EOF from self (done or shut_on_empty)
2736             output shutdown if closing flag set (my_pclose)
2737             send data/eof from child or eof from self
2738             otherwise, re-read (snarf of data from child)
2739     */
2740
2741     if (p->type == 1) {
2742         p->type = 0;
2743         if (myeof && p->chan_in) {                  /* input shutdown */
2744             _ckvmssts(sys$dassgn(p->chan_in));
2745             p->chan_in = 0;
2746         }
2747
2748         if (p->chan_out) {
2749             if (myeof || kideof) {      /* pass EOF to parent */
2750                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2751                               pipe_infromchild_ast, p,
2752                               0, 0, 0, 0, 0, 0));
2753                 return;
2754             } else if (eof) {       /* eat EOF --- fall through to read*/
2755
2756             } else {                /* transmit data */
2757                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2758                               pipe_infromchild_ast,p,
2759                               p->buf, p->iosb.count, 0, 0, 0, 0));
2760                 return;
2761             }
2762         }
2763     }
2764
2765     /*  everything shut? flag as done */
2766
2767     if (!p->chan_in && !p->chan_out) {
2768         *p->pipe_done = TRUE;
2769         _ckvmssts(sys$setef(pipe_ef));
2770         return;
2771     }
2772
2773     /* write completed (or read, if snarfing from child)
2774             if still have input active,
2775                queue read...immediate mode if shut_on_empty so we get EOF if empty
2776             otherwise,
2777                check if Perl reading, generate EOFs as needed
2778     */
2779
2780     if (p->type == 0) {
2781         p->type = 1;
2782         if (p->chan_in) {
2783             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2784                           pipe_infromchild_ast,p,
2785                           p->buf, p->bufsize, 0, 0, 0, 0);
2786             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2787             _ckvmssts(iss);
2788         } else {           /* send EOFs for extra reads */
2789             p->iosb.status = SS$_ENDOFFILE;
2790             p->iosb.dvispec = 0;
2791             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2792                       0, 0, 0,
2793                       pipe_infromchild_ast, p, 0, 0, 0, 0));
2794         }
2795     }
2796 }
2797
2798 static pPipe
2799 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2800 {
2801     pPipe p;
2802     char mbx[64];
2803     unsigned long dviitm = DVI$_DEVBUFSIZ;
2804     struct stat s;
2805     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2806                                       DSC$K_CLASS_S, mbx};
2807
2808     /* things like terminals and mbx's don't need this filter */
2809     if (fd && fstat(fd,&s) == 0) {
2810         unsigned long dviitm = DVI$_DEVCHAR, devchar;
2811         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2812                                          DSC$K_CLASS_S, s.st_dev};
2813
2814         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2815         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
2816             strcpy(out, s.st_dev);
2817             return 0;
2818         }
2819     }
2820
2821     Newx(p, 1, Pipe);
2822     p->fd_out = dup(fd);
2823     create_mbx(aTHX_ &p->chan_in, &d_mbx);
2824     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2825     Newx(p->buf, p->bufsize+1, char);
2826     p->shut_on_empty = FALSE;
2827     p->retry = 0;
2828     p->info  = 0;
2829     strcpy(out, mbx);
2830
2831     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2832                   pipe_mbxtofd_ast, p,
2833                   p->buf, p->bufsize, 0, 0, 0, 0));
2834
2835     return p;
2836 }
2837
2838 static void
2839 pipe_mbxtofd_ast(pPipe p)
2840 {
2841     int iss = p->iosb.status;
2842     int done = p->info->done;
2843     int iss2;
2844     int eof = (iss == SS$_ENDOFFILE);
2845     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2846     int err = !(iss&1) && !eof;
2847 #if defined(PERL_IMPLICIT_CONTEXT)
2848     pTHX = p->thx;
2849 #endif
2850
2851     if (done && myeof) {               /* end piping */
2852         close(p->fd_out);
2853         sys$dassgn(p->chan_in);
2854         *p->pipe_done = TRUE;
2855         _ckvmssts(sys$setef(pipe_ef));
2856         return;
2857     }
2858
2859     if (!err && !eof) {             /* good data to send to file */
2860         p->buf[p->iosb.count] = '\n';
2861         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2862         if (iss2 < 0) {
2863             p->retry++;
2864             if (p->retry < MAX_RETRY) {
2865                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2866                 return;
2867             }
2868         }
2869         p->retry = 0;
2870     } else if (err) {
2871         _ckvmssts(iss);
2872     }
2873
2874
2875     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2876           pipe_mbxtofd_ast, p,
2877           p->buf, p->bufsize, 0, 0, 0, 0);
2878     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2879     _ckvmssts(iss);
2880 }
2881
2882
2883 typedef struct _pipeloc     PLOC;
2884 typedef struct _pipeloc*   pPLOC;
2885
2886 struct _pipeloc {
2887     pPLOC   next;
2888     char    dir[NAM$C_MAXRSS+1];
2889 };
2890 static pPLOC  head_PLOC = 0;
2891
2892 void
2893 free_pipelocs(pTHX_ void *head)
2894 {
2895     pPLOC p, pnext;
2896     pPLOC *pHead = (pPLOC *)head;
2897
2898     p = *pHead;
2899     while (p) {
2900         pnext = p->next;
2901         PerlMem_free(p);
2902         p = pnext;
2903     }
2904     *pHead = 0;
2905 }
2906
2907 static void
2908 store_pipelocs(pTHX)
2909 {
2910     int    i;
2911     pPLOC  p;
2912     AV    *av = 0;
2913     SV    *dirsv;
2914     GV    *gv;
2915     char  *dir, *x;
2916     char  *unixdir;
2917     char  temp[NAM$C_MAXRSS+1];
2918     STRLEN n_a;
2919
2920     if (head_PLOC)
2921         free_pipelocs(aTHX_ &head_PLOC);
2922
2923 /*  the . directory from @INC comes last */
2924
2925     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2926     p->next = head_PLOC;
2927     head_PLOC = p;
2928     strcpy(p->dir,"./");
2929
2930 /*  get the directory from $^X */
2931
2932 #ifdef PERL_IMPLICIT_CONTEXT
2933     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2934 #else
2935     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
2936 #endif
2937         strcpy(temp, PL_origargv[0]);
2938         x = strrchr(temp,']');
2939         if (x == NULL) {
2940         x = strrchr(temp,'>');
2941           if (x == NULL) {
2942             /* It could be a UNIX path */
2943             x = strrchr(temp,'/');
2944           }
2945         }
2946         if (x)
2947           x[1] = '\0';
2948         else {
2949           /* Got a bare name, so use default directory */
2950           temp[0] = '.';
2951           temp[1] = '\0';
2952         }
2953
2954         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2955             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2956             p->next = head_PLOC;
2957             head_PLOC = p;
2958             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2959             p->dir[NAM$C_MAXRSS] = '\0';
2960         }
2961     }
2962
2963 /*  reverse order of @INC entries, skip "." since entered above */
2964
2965 #ifdef PERL_IMPLICIT_CONTEXT
2966     if (aTHX)
2967 #endif
2968     if (PL_incgv) av = GvAVn(PL_incgv);
2969
2970     for (i = 0; av && i <= AvFILL(av); i++) {
2971         dirsv = *av_fetch(av,i,TRUE);
2972
2973         if (SvROK(dirsv)) continue;
2974         dir = SvPVx(dirsv,n_a);
2975         if (strcmp(dir,".") == 0) continue;
2976         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2977             continue;
2978
2979         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2980         p->next = head_PLOC;
2981         head_PLOC = p;
2982         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2983         p->dir[NAM$C_MAXRSS] = '\0';
2984     }
2985
2986 /* most likely spot (ARCHLIB) put first in the list */
2987
2988 #ifdef ARCHLIB_EXP
2989     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2990         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2991         p->next = head_PLOC;
2992         head_PLOC = p;
2993         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2994         p->dir[NAM$C_MAXRSS] = '\0';
2995     }
2996 #endif
2997 }
2998
2999
3000 static char *
3001 find_vmspipe(pTHX)
3002 {
3003     static int   vmspipe_file_status = 0;
3004     static char  vmspipe_file[NAM$C_MAXRSS+1];
3005
3006     /* already found? Check and use ... need read+execute permission */
3007
3008     if (vmspipe_file_status == 1) {
3009         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3010          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3011             return vmspipe_file;
3012         }
3013         vmspipe_file_status = 0;
3014     }
3015
3016     /* scan through stored @INC, $^X */
3017
3018     if (vmspipe_file_status == 0) {
3019         char file[NAM$C_MAXRSS+1];
3020         pPLOC  p = head_PLOC;
3021
3022         while (p) {
3023             strcpy(file, p->dir);
3024             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3025             file[NAM$C_MAXRSS] = '\0';
3026             p = p->next;
3027
3028             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3029
3030             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3031              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3032                 vmspipe_file_status = 1;
3033                 return vmspipe_file;
3034             }
3035         }
3036         vmspipe_file_status = -1;   /* failed, use tempfiles */
3037     }
3038
3039     return 0;
3040 }
3041
3042 static FILE *
3043 vmspipe_tempfile(pTHX)
3044 {
3045     char file[NAM$C_MAXRSS+1];
3046     FILE *fp;
3047     static int index = 0;
3048     Stat_t s0, s1;
3049     int cmp_result;
3050
3051     /* create a tempfile */
3052
3053     /* we can't go from   W, shr=get to  R, shr=get without
3054        an intermediate vulnerable state, so don't bother trying...
3055
3056        and lib$spawn doesn't shr=put, so have to close the write
3057
3058        So... match up the creation date/time and the FID to
3059        make sure we're dealing with the same file
3060
3061     */
3062
3063     index++;
3064     if (!decc_filename_unix_only) {
3065       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3066       fp = fopen(file,"w");
3067       if (!fp) {
3068         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3069         fp = fopen(file,"w");
3070         if (!fp) {
3071             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3072             fp = fopen(file,"w");
3073         }
3074       }
3075      }
3076      else {
3077       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3078       fp = fopen(file,"w");
3079       if (!fp) {
3080         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3081         fp = fopen(file,"w");
3082         if (!fp) {
3083           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3084           fp = fopen(file,"w");
3085         }
3086       }
3087     }
3088     if (!fp) return 0;  /* we're hosed */
3089
3090     fprintf(fp,"$! 'f$verify(0)'\n");
3091     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3092     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3093     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3094     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3095     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3096     fprintf(fp,"$ perl_del    = \"delete\"\n");
3097     fprintf(fp,"$ pif         = \"if\"\n");
3098     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3099     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3100     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3101     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3102     fprintf(fp,"$!  --- build command line to get max possible length\n");
3103     fprintf(fp,"$c=perl_popen_cmd0\n");
3104     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3105     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3106     fprintf(fp,"$x=perl_popen_cmd3\n");
3107     fprintf(fp,"$c=c+x\n");
3108     fprintf(fp,"$ perl_on\n");
3109     fprintf(fp,"$ 'c'\n");
3110     fprintf(fp,"$ perl_status = $STATUS\n");
3111     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3112     fprintf(fp,"$ perl_exit 'perl_status'\n");
3113     fsync(fileno(fp));
3114
3115     fgetname(fp, file, 1);
3116     fstat(fileno(fp), (struct stat *)&s0);
3117     fclose(fp);
3118
3119     if (decc_filename_unix_only)
3120         do_tounixspec(file, file, 0);
3121     fp = fopen(file,"r","shr=get");
3122     if (!fp) return 0;
3123     fstat(fileno(fp), (struct stat *)&s1);
3124
3125     #if defined(_USE_STD_STAT)
3126       cmp_result = s0.crtl_stat.st_ino != s1.crtl_stat.st_ino;
3127     #else
3128       cmp_result = memcmp(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino, 6);
3129     #endif
3130     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3131         fclose(fp);
3132         return 0;
3133     }
3134
3135     return fp;
3136 }
3137
3138
3139
3140 static PerlIO *
3141 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3142 {
3143     static int handler_set_up = FALSE;
3144     unsigned long int sts, flags = CLI$M_NOWAIT;
3145     /* The use of a GLOBAL table (as was done previously) rendered
3146      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3147      * environment.  Hence we've switched to LOCAL symbol table.
3148      */
3149     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3150     int j, wait = 0;
3151     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3152     char in[512], out[512], err[512], mbx[512];
3153     FILE *tpipe = 0;
3154     char tfilebuf[NAM$C_MAXRSS+1];
3155     pInfo info;
3156     char cmd_sym_name[20];
3157     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3158                                       DSC$K_CLASS_S, symbol};
3159     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3160                                       DSC$K_CLASS_S, 0};
3161     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3162                                       DSC$K_CLASS_S, cmd_sym_name};
3163     struct dsc$descriptor_s *vmscmd;
3164     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3165     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3166     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3167
3168     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3169
3170     /* once-per-program initialization...
3171        note that the SETAST calls and the dual test of pipe_ef
3172        makes sure that only the FIRST thread through here does
3173        the initialization...all other threads wait until it's
3174        done.
3175
3176        Yeah, uglier than a pthread call, it's got all the stuff inline
3177        rather than in a separate routine.
3178     */
3179
3180     if (!pipe_ef) {
3181         _ckvmssts(sys$setast(0));
3182         if (!pipe_ef) {
3183             unsigned long int pidcode = JPI$_PID;
3184             $DESCRIPTOR(d_delay, RETRY_DELAY);
3185             _ckvmssts(lib$get_ef(&pipe_ef));
3186             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3187             _ckvmssts(sys$bintim(&d_delay, delaytime));
3188         }
3189         if (!handler_set_up) {
3190           _ckvmssts(sys$dclexh(&pipe_exitblock));
3191           handler_set_up = TRUE;
3192         }
3193         _ckvmssts(sys$setast(1));
3194     }
3195
3196     /* see if we can find a VMSPIPE.COM */
3197
3198     tfilebuf[0] = '@';
3199     vmspipe = find_vmspipe(aTHX);
3200     if (vmspipe) {
3201         strcpy(tfilebuf+1,vmspipe);
3202     } else {        /* uh, oh...we're in tempfile hell */
3203         tpipe = vmspipe_tempfile(aTHX);
3204         if (!tpipe) {       /* a fish popular in Boston */
3205             if (ckWARN(WARN_PIPE)) {
3206                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3207             }
3208         return Nullfp;
3209         }
3210         fgetname(tpipe,tfilebuf+1,1);
3211     }
3212     vmspipedsc.dsc$a_pointer = tfilebuf;
3213     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3214
3215     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3216     if (!(sts & 1)) {
3217       switch (sts) {
3218         case RMS$_FNF:  case RMS$_DNF:
3219           set_errno(ENOENT); break;
3220         case RMS$_DIR:
3221           set_errno(ENOTDIR); break;
3222         case RMS$_DEV:
3223           set_errno(ENODEV); break;
3224         case RMS$_PRV:
3225           set_errno(EACCES); break;
3226         case RMS$_SYN:
3227           set_errno(EINVAL); break;
3228         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3229           set_errno(E2BIG); break;
3230         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3231           _ckvmssts(sts); /* fall through */
3232         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3233           set_errno(EVMSERR);
3234       }
3235       set_vaxc_errno(sts);
3236       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3237         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3238       }
3239       *psts = sts;
3240       return Nullfp;
3241     }
3242     Newx(info,1,Info);
3243
3244     strcpy(mode,in_mode);
3245     info->mode = *mode;
3246     info->done = FALSE;
3247     info->completion = 0;
3248     info->closing    = FALSE;
3249     info->in         = 0;
3250     info->out        = 0;
3251     info->err        = 0;
3252     info->fp         = Nullfp;
3253     info->useFILE    = 0;
3254     info->waiting    = 0;
3255     info->in_done    = TRUE;
3256     info->out_done   = TRUE;
3257     info->err_done   = TRUE;
3258     in[0] = out[0] = err[0] = '\0';
3259
3260     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3261         info->useFILE = 1;
3262         strcpy(p,p+1);
3263     }
3264     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3265         wait = 1;
3266         strcpy(p,p+1);
3267     }
3268
3269     if (*mode == 'r') {             /* piping from subroutine */
3270
3271         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3272         if (info->out) {
3273             info->out->pipe_done = &info->out_done;
3274             info->out_done = FALSE;
3275             info->out->info = info;
3276         }
3277         if (!info->useFILE) {
3278         info->fp  = PerlIO_open(mbx, mode);
3279         } else {
3280             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3281             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3282         }
3283
3284         if (!info->fp && info->out) {
3285             sys$cancel(info->out->chan_out);
3286
3287             while (!info->out_done) {
3288                 int done;
3289                 _ckvmssts(sys$setast(0));
3290                 done = info->out_done;
3291                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3292                 _ckvmssts(sys$setast(1));
3293                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3294             }
3295
3296             if (info->out->buf) Safefree(info->out->buf);
3297             Safefree(info->out);
3298             Safefree(info);
3299             *psts = RMS$_FNF;
3300             return Nullfp;
3301         }
3302
3303         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3304         if (info->err) {
3305             info->err->pipe_done = &info->err_done;
3306             info->err_done = FALSE;
3307             info->err->info = info;
3308         }
3309
3310     } else if (*mode == 'w') {      /* piping to subroutine */
3311
3312         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3313         if (info->out) {
3314             info->out->pipe_done = &info->out_done;
3315             info->out_done = FALSE;
3316             info->out->info = info;
3317         }
3318
3319         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3320         if (info->err) {
3321             info->err->pipe_done = &info->err_done;
3322             info->err_done = FALSE;
3323             info->err->info = info;
3324         }
3325
3326         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3327         if (!info->useFILE) {
3328         info->fp  = PerlIO_open(mbx, mode);
3329         } else {
3330             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3331             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3332         }
3333
3334         if (info->in) {
3335             info->in->pipe_done = &info->in_done;
3336             info->in_done = FALSE;
3337             info->in->info = info;
3338         }
3339
3340         /* error cleanup */
3341         if (!info->fp && info->in) {
3342             info->done = TRUE;
3343             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3344                               0, 0, 0, 0, 0, 0, 0, 0));
3345
3346             while (!info->in_done) {
3347                 int done;
3348                 _ckvmssts(sys$setast(0));
3349                 done = info->in_done;
3350                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3351                 _ckvmssts(sys$setast(1));
3352                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3353             }
3354
3355             if (info->in->buf) Safefree(info->in->buf);
3356             Safefree(info->in);
3357             Safefree(info);
3358             *psts = RMS$_FNF;
3359             return Nullfp;
3360         }
3361
3362
3363     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3364         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3365         if (info->out) {
3366             info->out->pipe_done = &info->out_done;
3367             info->out_done = FALSE;
3368             info->out->info = info;
3369         }
3370
3371         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3372         if (info->err) {
3373             info->err->pipe_done = &info->err_done;
3374             info->err_done = FALSE;
3375             info->err->info = info;
3376         }
3377     }
3378
3379     symbol[MAX_DCL_SYMBOL] = '\0';
3380
3381     strncpy(symbol, in, MAX_DCL_SYMBOL);
3382     d_symbol.dsc$w_length = strlen(symbol);
3383     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3384
3385     strncpy(symbol, err, MAX_DCL_SYMBOL);
3386     d_symbol.dsc$w_length = strlen(symbol);
3387     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3388
3389     strncpy(symbol, out, MAX_DCL_SYMBOL);
3390     d_symbol.dsc$w_length = strlen(symbol);
3391     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3392
3393     p = vmscmd->dsc$a_pointer;
3394     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
3395     if (*p == '$') p++;                         /* remove leading $ */
3396     while (*p == ' ' || *p == '\t') p++;
3397
3398     for (j = 0; j < 4; j++) {
3399         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3400         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3401
3402     strncpy(symbol, p, MAX_DCL_SYMBOL);
3403     d_symbol.dsc$w_length = strlen(symbol);
3404     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3405
3406         if (strlen(p) > MAX_DCL_SYMBOL) {
3407             p += MAX_DCL_SYMBOL;
3408         } else {
3409             p += strlen(p);
3410         }
3411     }
3412     _ckvmssts(sys$setast(0));
3413     info->next=open_pipes;  /* prepend to list */
3414     open_pipes=info;
3415     _ckvmssts(sys$setast(1));
3416     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3417      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
3418      * have SYS$COMMAND if we need it.
3419      */
3420     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3421                       0, &info->pid, &info->completion,
3422                       0, popen_completion_ast,info,0,0,0));
3423
3424     /* if we were using a tempfile, close it now */
3425
3426     if (tpipe) fclose(tpipe);
3427
3428     /* once the subprocess is spawned, it has copied the symbols and
3429        we can get rid of ours */
3430
3431     for (j = 0; j < 4; j++) {
3432         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3433         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3434     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3435     }
3436     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
3437     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3438     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3439     vms_execfree(vmscmd);
3440
3441 #ifdef PERL_IMPLICIT_CONTEXT
3442     if (aTHX)
3443 #endif
3444     PL_forkprocess = info->pid;
3445
3446     if (wait) {
3447          int done = 0;
3448          while (!done) {
3449              _ckvmssts(sys$setast(0));
3450              done = info->done;
3451              if (!done) _ckvmssts(sys$clref(pipe_ef));
3452              _ckvmssts(sys$setast(1));
3453              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3454          }
3455         *psts = info->completion;
3456 /* Caller thinks it is open and tries to close it. */
3457 /* This causes some problems, as it changes the error status */
3458 /*        my_pclose(info->fp); */
3459     } else {
3460         *psts = SS$_NORMAL;
3461     }
3462     return info->fp;
3463 }  /* end of safe_popen */
3464
3465
3466 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
3467 PerlIO *
3468 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3469 {
3470     int sts;
3471     TAINT_ENV();
3472     TAINT_PROPER("popen");
3473     PERL_FLUSHALL_FOR_CHILD;
3474     return safe_popen(aTHX_ cmd,mode,&sts);
3475 }
3476
3477 /*}}}*/
3478
3479 /*{{{  I32 my_pclose(PerlIO *fp)*/
3480 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3481 {
3482     pInfo info, last = NULL;
3483     unsigned long int retsts;
3484     int done, iss;
3485
3486     for (info = open_pipes; info != NULL; last = info, info = info->next)
3487         if (info->fp == fp) break;
3488
3489     if (info == NULL) {  /* no such pipe open */
3490       set_errno(ECHILD); /* quoth POSIX */
3491       set_vaxc_errno(SS$_NONEXPR);
3492       return -1;
3493     }
3494
3495     /* If we were writing to a subprocess, insure that someone reading from
3496      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
3497      * produce an EOF record in the mailbox.
3498      *
3499      *  well, at least sometimes it *does*, so we have to watch out for
3500      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
3501      */
3502      if (info->fp) {
3503         if (!info->useFILE)
3504      PerlIO_flush(info->fp);   /* first, flush data */
3505         else
3506             fflush((FILE *)info->fp);
3507     }
3508
3509     _ckvmssts(sys$setast(0));
3510      info->closing = TRUE;
3511      done = info->done && info->in_done && info->out_done && info->err_done;
3512      /* hanging on write to Perl's input? cancel it */
3513      if (info->mode == 'r' && info->out && !info->out_done) {
3514         if (info->out->chan_out) {
3515             _ckvmssts(sys$cancel(info->out->chan_out));
3516             if (!info->out->chan_in) {   /* EOF generation, need AST */
3517                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3518             }
3519         }
3520      }
3521      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
3522          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3523                            0, 0, 0, 0, 0, 0));
3524     _ckvmssts(sys$setast(1));
3525     if (info->fp) {
3526      if (!info->useFILE)
3527     PerlIO_close(info->fp);
3528      else
3529         fclose((FILE *)info->fp);
3530     }
3531      /*
3532         we have to wait until subprocess completes, but ALSO wait until all
3533         the i/o completes...otherwise we'll be freeing the "info" structure
3534         that the i/o ASTs could still be using...
3535      */
3536
3537      while (!done) {
3538          _ckvmssts(sys$setast(0));
3539          done = info->done && info->in_done && info->out_done && info->err_done;
3540          if (!done) _ckvmssts(sys$clref(pipe_ef));
3541          _ckvmssts(sys$setast(1));
3542          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3543      }
3544      retsts = info->completion;
3545
3546     /* remove from list of open pipes */
3547     _ckvmssts(sys$setast(0));
3548     if (last) last->next = info->next;
3549     else open_pipes = info->next;
3550     _ckvmssts(sys$setast(1));
3551
3552     /* free buffers and structures */
3553
3554     if (info->in) {
3555         if (info->in->buf) Safefree(info->in->buf);
3556         Safefree(info->in);
3557     }
3558     if (info->out) {
3559         if (info->out->buf) Safefree(info->out->buf);
3560         Safefree(info->out);
3561     }
3562     if (info->err) {
3563         if (info->err->buf) Safefree(info->err->buf);
3564         Safefree(info->err);
3565     }
3566     Safefree(info);
3567
3568     return retsts;
3569
3570 }  /* end of my_pclose() */
3571
3572 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3573   /* Roll our own prototype because we want this regardless of whether
3574    * _VMS_WAIT is defined.
3575    */
3576   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3577 #endif
3578 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3579    created with popen(); otherwise partially emulate waitpid() unless
3580    we have a suitable one from the CRTL that came with VMS 7.2 and later.
3581    Also check processes not considered by the CRTL waitpid().
3582  */
3583 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3584 Pid_t
3585 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3586 {
3587     pInfo info;
3588     int done;
3589     int sts;
3590     int j;
3591
3592     if (statusp) *statusp = 0;
3593
3594     for (info = open_pipes; info != NULL; info = info->next)
3595         if (info->pid == pid) break;
3596
3597     if (info != NULL) {  /* we know about this child */
3598       while (!info->done) {
3599           _ckvmssts(sys$setast(0));
3600           done = info->done;
3601           if (!done) _ckvmssts(sys$clref(pipe_ef));
3602           _ckvmssts(sys$setast(1));
3603           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3604       }
3605
3606       if (statusp) *statusp = info->completion;
3607       return pid;
3608     }
3609
3610     /* child that already terminated? */
3611
3612     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3613         if (closed_list[j].pid == pid) {
3614             if (statusp) *statusp = closed_list[j].completion;
3615             return pid;
3616         }
3617     }
3618
3619     /* fall through if this child is not one of our own pipe children */
3620
3621 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3622
3623       /* waitpid() became available in the CRTL as of VMS 7.0, but only
3624        * in 7.2 did we get a version that fills in the VMS completion
3625        * status as Perl has always tried to do.
3626        */
3627
3628       sts = __vms_waitpid( pid, statusp, flags );
3629
3630       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3631          return sts;
3632
3633       /* If the real waitpid tells us the child does not exist, we
3634        * fall through here to implement waiting for a child that
3635        * was created by some means other than exec() (say, spawned
3636        * from DCL) or to wait for a process that is not a subprocess
3637        * of the current process.
3638        */
3639
3640 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3641
3642     {
3643       $DESCRIPTOR(intdsc,"0 00:00:01");
3644       unsigned long int ownercode = JPI$_OWNER, ownerpid;
3645       unsigned long int pidcode = JPI$_PID, mypid;
3646       unsigned long int interval[2];
3647       unsigned int jpi_iosb[2];
3648       struct itmlst_3 jpilist[2] = {
3649           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
3650           {                      0,         0,                 0, 0}
3651       };
3652
3653       if (pid <= 0) {
3654         /* Sorry folks, we don't presently implement rooting around for
3655            the first child we can find, and we definitely don't want to
3656            pass a pid of -1 to $getjpi, where it is a wildcard operation.
3657          */
3658         set_errno(ENOTSUP);
3659         return -1;
3660       }
3661
3662       /* Get the owner of the child so I can warn if it's not mine. If the
3663        * process doesn't exist or I don't have the privs to look at it,
3664        * I can go home early.
3665        */
3666       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3667       if (sts & 1) sts = jpi_iosb[0];
3668       if (!(sts & 1)) {
3669         switch (sts) {
3670             case SS$_NONEXPR:
3671                 set_errno(ECHILD);
3672                 break;
3673             case SS$_NOPRIV:
3674                 set_errno(EACCES);
3675                 break;
3676             default:
3677                 _ckvmssts(sts);
3678         }
3679         set_vaxc_errno(sts);
3680         return -1;
3681       }
3682
3683       if (ckWARN(WARN_EXEC)) {
3684         /* remind folks they are asking for non-standard waitpid behavior */
3685         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3686         if (ownerpid != mypid)
3687           Perl_warner(aTHX_ packWARN(WARN_EXEC),
3688                       "waitpid: process %x is not a child of process %x",
3689                       pid,mypid);
3690       }
3691
3692       /* simply check on it once a second until it's not there anymore. */
3693
3694       _ckvmssts(sys$bintim(&intdsc,interval));
3695       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3696             _ckvmssts(sys$schdwk(0,0,interval,0));
3697             _ckvmssts(sys$hiber());
3698       }
3699       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3700
3701       _ckvmssts(sts);
3702       return pid;
3703     }
3704 }  /* end of waitpid() */
3705 /*}}}*/
3706 /*}}}*/
3707 /*}}}*/
3708
3709 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3710 char *
3711 my_gconvert(double val, int ndig, int trail, char *buf)
3712 {
3713   static char __gcvtbuf[DBL_DIG+1];
3714   char *loc;
3715
3716   loc = buf ? buf : __gcvtbuf;
3717
3718 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
3719   if (val < 1) {
3720     sprintf(loc,"%.*g",ndig,val);
3721     return loc;
3722   }
3723 #endif
3724
3725   if (val) {
3726     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3727     return gcvt(val,ndig,loc);
3728   }
3729   else {
3730     loc[0] = '0'; loc[1] = '\0';
3731     return loc;
3732   }
3733
3734 }
3735 /*}}}*/
3736
3737
3738 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3739 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
3740  * to expand file specification.  Allows for a single default file
3741  * specification and a simple mask of options.  If outbuf is non-NULL,
3742  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3743  * the resultant file specification is placed.  If outbuf is NULL, the
3744  * resultant file specification is placed into a static buffer.
3745  * The third argument, if non-NULL, is taken to be a default file
3746  * specification string.  The fourth argument is unused at present.
3747  * rmesexpand() returns the address of the resultant string if
3748  * successful, and NULL on error.
3749  *
3750  * New functionality for previously unused opts value:
3751  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
3752  */
3753 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
3754
3755 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
3756 /* ODS-2 only version */
3757 static char *
3758 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3759 {
3760   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
3761   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
3762   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3763   struct FAB myfab = cc$rms_fab;
3764   struct NAM mynam = cc$rms_nam;
3765   STRLEN speclen;
3766   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3767   int sts;
3768
3769   if (!filespec || !*filespec) {
3770     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3771     return NULL;
3772   }
3773   if (!outbuf) {
3774     if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
3775     else    outbuf = __rmsexpand_retbuf;
3776   }
3777   isunix = is_unix_filespec(filespec);
3778   if (isunix) {
3779     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
3780         if (out)
3781            Safefree(out);
3782         return NULL;
3783     }
3784     filespec = vmsfspec;
3785   }
3786
3787   myfab.fab$l_fna = (char *)filespec;  /* cast ok for read only pointer */
3788   myfab.fab$b_fns = strlen(filespec);
3789   myfab.fab$l_nam = &mynam;
3790
3791   if (defspec && *defspec) {
3792     if (strchr(defspec,'/') != NULL) {
3793       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
3794         if (out)
3795            Safefree(out);
3796         return NULL;
3797       }
3798       defspec = tmpfspec;
3799     }
3800     myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
3801     myfab.fab$b_dns = strlen(defspec);
3802   }
3803
3804   mynam.nam$l_esa = esa;
3805   mynam.nam$b_ess = sizeof esa;
3806   mynam.nam$l_rsa = outbuf;
3807   mynam.nam$b_rss = NAM$C_MAXRSS;
3808
3809 #ifdef NAM$M_NO_SHORT_UPCASE
3810   if (decc_efs_case_preserve)
3811     mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3812 #endif
3813
3814   retsts = sys$parse(&myfab,0,0);
3815   if (!(retsts & 1)) {
3816     mynam.nam$b_nop |= NAM$M_SYNCHK;
3817     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
3818       retsts = sys$parse(&myfab,0,0);
3819       if (retsts & 1) goto expanded;
3820     }
3821     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3822     sts = sys$parse(&myfab,0,0);  /* Free search context */
3823     if (out) Safefree(out);
3824     set_vaxc_errno(retsts);
3825     if      (retsts == RMS$_PRV) set_errno(EACCES);
3826     else if (retsts == RMS$_DEV) set_errno(ENODEV);
3827     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3828     else                         set_errno(EVMSERR);
3829     return NULL;
3830   }
3831   retsts = sys$search(&myfab,0,0);
3832   if (!(retsts & 1) && retsts != RMS$_FNF) {
3833     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3834     myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);  /* Free search context */
3835     if (out) Safefree(out);
3836     set_vaxc_errno(retsts);
3837     if      (retsts == RMS$_PRV) set_errno(EACCES);
3838     else                         set_errno(EVMSERR);
3839     return NULL;
3840   }
3841
3842   /* If the input filespec contained any lowercase characters,
3843    * downcase the result for compatibility with Unix-minded code. */
3844   expanded:
3845   if (!decc_efs_case_preserve) {
3846     for (out = myfab.fab$l_fna; *out; out++)
3847       if (islower(*out)) { haslower = 1; break; }
3848   }
3849   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3850   else                 { out = esa;    speclen = mynam.nam$b_esl; }
3851   /* Trim off null fields added by $PARSE
3852    * If type > 1 char, must have been specified in original or default spec
3853    * (not true for version; $SEARCH may have added version of existing file).
3854    */
3855   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3856   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3857              (mynam.nam$l_ver - mynam.nam$l_type == 1);
3858   if (trimver || trimtype) {
3859     if (defspec && *defspec) {
3860       char defesa[NAM$C_MAXRSS];
3861       struct FAB deffab = cc$rms_fab;
3862       struct NAM defnam = cc$rms_nam;
3863
3864       deffab.fab$l_nam = &defnam;
3865       /* cast below ok for read only pointer */
3866       deffab.fab$l_fna = (char *)defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
3867       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
3868       defnam.nam$b_nop = NAM$M_SYNCHK;
3869 #ifdef NAM$M_NO_SHORT_UPCASE
3870       if (decc_efs_case_preserve)
3871         defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3872 #endif
3873       if (sys$parse(&deffab,0,0) & 1) {
3874         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
3875         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
3876       }
3877     }
3878     if (trimver) {
3879       if (*mynam.nam$l_ver != '\"')
3880         speclen = mynam.nam$l_ver - out;
3881     }
3882     if (trimtype) {
3883       /* If we didn't already trim version, copy down */
3884       if (speclen > mynam.nam$l_ver - out)
3885         memmove(mynam.nam$l_type, mynam.nam$l_ver,
3886                speclen - (mynam.nam$l_ver - out));
3887       speclen -= mynam.nam$l_ver - mynam.nam$l_type;
3888     }
3889   }
3890   /* If we just had a directory spec on input, $PARSE "helpfully"
3891    * adds an empty name and type for us */
3892   if (mynam.nam$l_name == mynam.nam$l_type &&
3893       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
3894       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
3895     speclen = mynam.nam$l_name - out;
3896
3897   /* Posix format specifications must have matching quotes */
3898   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
3899     if ((speclen > 1) && (out[speclen-1] != '\"')) {
3900       out[speclen] = '\"';
3901       speclen++;
3902     }
3903   }
3904
3905   out[speclen] = '\0';
3906   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
3907
3908   /* Have we been working with an expanded, but not resultant, spec? */
3909   /* Also, convert back to Unix syntax if necessary. */
3910   if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
3911     isunix = 0;
3912
3913   if (!mynam.nam$b_rsl) {
3914     if (isunix) {
3915       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
3916     }
3917     else strcpy(outbuf,esa);
3918   }
3919   else if (isunix) {
3920     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
3921     strcpy(outbuf,tmpfspec);
3922   }
3923   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3924   mynam.nam$l_rsa = NULL;
3925   mynam.nam$b_rss = 0;
3926   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);  /* Free search context */
3927   return outbuf;
3928 }
3929 #else
3930 /* ODS-5 supporting routine */
3931 static char *
3932 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3933 {
3934   static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
3935   char * vmsfspec, *tmpfspec;
3936   char * esa, *cp, *out = NULL;
3937   char * esal;
3938   char * outbufl;
3939   struct FAB myfab = cc$rms_fab;
3940   struct NAML mynam = cc$rms_naml;
3941   STRLEN speclen;
3942   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3943   int sts;
3944
3945   if (!filespec || !*filespec) {
3946     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3947     return NULL;
3948   }
3949   if (!outbuf) {
3950     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
3951     else    outbuf = __rmsexpand_retbuf;
3952   }
3953
3954   vmsfspec = NULL;
3955   tmpfspec = NULL;
3956   outbufl = NULL;
3957   isunix = is_unix_filespec(filespec);
3958   if (isunix) {
3959     Newx(vmsfspec, VMS_MAXRSS, char);
3960     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
3961         Safefree(vmsfspec);
3962         if (out)
3963            Safefree(out);
3964         return NULL;
3965     }
3966     filespec = vmsfspec;
3967
3968      /* Unless we are forcing to VMS format, a UNIX input means
3969       * UNIX output, and that requires long names to be used
3970       */
3971     if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
3972         opts |= PERL_RMSEXPAND_M_LONG;
3973     else {
3974         isunix = 0;
3975     }
3976   }
3977
3978   myfab.fab$l_fna = (char *)-1; /* cast ok */
3979   myfab.fab$b_fns = 0;
3980   mynam.naml$l_long_filename = (char *)filespec; /* cast ok */
3981   mynam.naml$l_long_filename_size = strlen(filespec);
3982   myfab.fab$l_naml = &mynam;
3983
3984   if (defspec && *defspec) {
3985     int t_isunix;
3986     t_isunix = is_unix_filespec(defspec);
3987     if (t_isunix) {
3988       Newx(tmpfspec, VMS_MAXRSS, char);
3989       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
3990         Safefree(tmpfspec);
3991         if (vmsfspec != NULL)
3992             Safefree(vmsfspec);
3993         if (out)
3994            Safefree(out);
3995         return NULL;
3996       }
3997       defspec = tmpfspec;
3998     }
3999     myfab.fab$l_dna = (char *) -1; /* cast ok */
4000     myfab.fab$b_dns = 0;
4001     mynam.naml$l_long_defname = (char *)defspec; /* cast ok */
4002     mynam.naml$l_long_defname_size = strlen(defspec);
4003   }
4004
4005   Newx(esa, NAM$C_MAXRSS + 1, char);
4006   Newx(esal, NAML$C_MAXRSS + 1, char);
4007   mynam.naml$l_esa = esa;
4008   mynam.naml$b_ess = NAM$C_MAXRSS;
4009   mynam.naml$l_long_expand = esal;
4010   mynam.naml$l_long_expand_alloc = NAML$C_MAXRSS;
4011
4012   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4013     mynam.naml$l_rsa = NULL;
4014     mynam.naml$b_rss = 0;
4015     mynam.naml$l_long_result = outbuf;
4016     mynam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
4017   }
4018   else {
4019     mynam.naml$l_rsa = outbuf;
4020     mynam.naml$b_rss = NAM$C_MAXRSS;
4021     Newx(outbufl, VMS_MAXRSS, char);
4022     mynam.naml$l_long_result = outbufl;
4023     mynam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
4024   }
4025
4026 #ifdef NAM$M_NO_SHORT_UPCASE
4027   if (decc_efs_case_preserve)
4028     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
4029 #endif
4030
4031   /* First attempt to parse as an existing file */
4032   retsts = sys$parse(&myfab,0,0);
4033   if (!(retsts & STS$K_SUCCESS)) {
4034
4035     /* Could not find the file, try as syntax only if error is not fatal */
4036     mynam.naml$b_nop |= NAM$M_SYNCHK;
4037     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4038       retsts = sys$parse(&myfab,0,0);
4039       if (retsts & STS$K_SUCCESS) goto expanded;
4040     }
4041
4042      /* Still could not parse the file specification */
4043     /*----------------------------------------------*/
4044     mynam.naml$l_rlf = NULL;
4045     myfab.fab$b_dns = 0;
4046     mynam.naml$l_long_defname_size = 0;
4047     sts = sys$parse(&myfab,0,0);  /* Free search context */
4048     if (out) Safefree(out);
4049     if (tmpfspec != NULL)
4050         Safefree(tmpfspec);
4051     if (vmsfspec != NULL)
4052         Safefree(vmsfspec);
4053     Safefree(esa);
4054     Safefree(esal);
4055     set_vaxc_errno(retsts);
4056     if      (retsts == RMS$_PRV) set_errno(EACCES);
4057     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4058     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4059     else                         set_errno(EVMSERR);
4060     return NULL;
4061   }
4062   retsts = sys$search(&myfab,0,0);
4063   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4064     mynam.naml$b_nop |= NAM$M_SYNCHK;
4065     mynam.naml$l_rlf = NULL;
4066     myfab.fab$b_dns = 0;
4067     mynam.naml$l_long_defname_size = 0;
4068     sts = sys$parse(&myfab,0,0);  /* Free search context */
4069     if (out) Safefree(out);
4070     if (tmpfspec != NULL)
4071         Safefree(tmpfspec);
4072     if (vmsfspec != NULL)
4073         Safefree(vmsfspec);
4074     Safefree(esa);
4075     Safefree(esal);
4076     set_vaxc_errno(retsts);
4077     if      (retsts == RMS$_PRV) set_errno(EACCES);
4078     else                         set_errno(EVMSERR);
4079     return NULL;
4080   }
4081
4082   /* If the input filespec contained any lowercase characters,
4083    * downcase the result for compatibility with Unix-minded code. */
4084   expanded:
4085   if (!decc_efs_case_preserve) {
4086     for (out = mynam.naml$l_long_filename; *out; out++)
4087       if (islower(*out)) { haslower = 1; break; }
4088   }
4089
4090    /* Is a long or a short name expected */
4091   /*------------------------------------*/
4092   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4093     if (mynam.naml$l_long_result_size) {
4094         out = outbuf;
4095         speclen = mynam.naml$l_long_result_size;
4096     }
4097     else {
4098         out = esal; /* Not esa */
4099         speclen = mynam.naml$l_long_expand_size;
4100     }
4101   }
4102   else {
4103     if (mynam.naml$b_rsl) {
4104         out = outbuf;
4105         speclen = mynam.naml$b_rsl;
4106     }
4107     else {
4108         out = esa; /* Not esal */
4109         speclen = mynam.naml$b_esl;
4110     }
4111   }
4112   /* Trim off null fields added by $PARSE
4113    * If type > 1 char, must have been specified in original or default spec
4114    * (not true for version; $SEARCH may have added version of existing file).
4115    */
4116   trimver  = !(mynam.naml$l_fnb & NAM$M_EXP_VER);
4117   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4118     trimtype = !(mynam.naml$l_fnb & NAM$M_EXP_TYPE) &&
4119              (mynam.naml$l_long_ver - mynam.naml$l_long_type == 1);
4120   }
4121   else {
4122     trimtype = !(mynam.naml$l_fnb & NAM$M_EXP_TYPE) &&
4123              (mynam.naml$l_ver - mynam.naml$l_type == 1);
4124   }
4125   if (trimver || trimtype) {
4126     if (defspec && *defspec) {
4127       char *defesal = NULL;
4128       Newx(defesal, NAML$C_MAXRSS + 1, char);
4129       if (defesal != NULL) {
4130         struct FAB deffab = cc$rms_fab;
4131         struct NAML defnam = cc$rms_naml;
4132
4133         deffab.fab$l_naml = &defnam;
4134
4135         deffab.fab$l_fna = (char *) - 1; /* Cast ok */
4136         deffab.fab$b_fns = 0;
4137         defnam.naml$l_long_filename = (char *)defspec; /* Cast ok */
4138         defnam.naml$l_long_filename_size = mynam.naml$l_long_defname_size;
4139         defnam.naml$l_esa = NULL;
4140         defnam.naml$b_ess = 0;
4141         defnam.naml$l_long_expand = defesal;
4142         defnam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
4143         defnam.naml$b_nop = NAM$M_SYNCHK;
4144 #ifdef NAM$M_NO_SHORT_UPCASE
4145         if (decc_efs_case_preserve)
4146           defnam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
4147 #endif
4148         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4149           if (trimver) {
4150              trimver  = !(defnam.naml$l_fnb & NAM$M_EXP_VER);
4151           }
4152           if (trimtype) {
4153             trimtype = !(defnam.naml$l_fnb & NAM$M_EXP_TYPE);
4154           }
4155         }
4156         Safefree(defesal);
4157       }
4158     }
4159     if (trimver) {
4160       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4161         if (*mynam.naml$l_long_ver != '\"')
4162           speclen = mynam.naml$l_long_ver - out;
4163       }
4164       else {
4165         if (*mynam.naml$l_ver != '\"')
4166           speclen = mynam.naml$l_ver - out;
4167       }
4168     }
4169     if (trimtype) {
4170       /* If we didn't already trim version, copy down */
4171       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4172         if (speclen > mynam.naml$l_long_ver - out)
4173           memmove
4174            (mynam.naml$l_long_type,
4175             mynam.naml$l_long_ver,
4176             speclen - (mynam.naml$l_long_ver - out));
4177           speclen -= mynam.naml$l_long_ver - mynam.naml$l_long_type;
4178       }
4179       else {
4180         if (speclen > mynam.naml$l_ver - out)
4181           memmove
4182            (mynam.naml$l_type,
4183             mynam.naml$l_ver,
4184             speclen - (mynam.naml$l_ver - out));
4185           speclen -= mynam.naml$l_ver - mynam.naml$l_type;
4186       }
4187     }
4188   }
4189
4190    /* Done with these copies of the input files */
4191   /*-------------------------------------------*/
4192   if (vmsfspec != NULL)
4193         Safefree(vmsfspec);
4194   if (tmpfspec != NULL)
4195         Safefree(tmpfspec);
4196
4197   /* If we just had a directory spec on input, $PARSE "helpfully"
4198    * adds an empty name and type for us */
4199   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4200     if (mynam.naml$l_long_name == mynam.naml$l_long_type &&
4201         mynam.naml$l_long_ver  == mynam.naml$l_long_type + 1 &&
4202         !(mynam.naml$l_fnb & NAM$M_EXP_NAME))
4203       speclen = mynam.naml$l_long_name - out;
4204   }
4205   else {
4206     if (mynam.naml$l_name == mynam.naml$l_type &&
4207         mynam.naml$l_ver  == mynam.naml$l_type + 1 &&
4208         !(mynam.naml$l_fnb & NAM$M_EXP_NAME))
4209       speclen = mynam.naml$l_name - out;
4210   }
4211
4212   /* Posix format specifications must have matching quotes */
4213   if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4214     if ((speclen > 1) && (out[speclen-1] != '\"')) {
4215       out[speclen] = '\"';
4216       speclen++;
4217     }
4218   }
4219   out[speclen] = '\0';
4220   if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4221
4222   /* Have we been working with an expanded, but not resultant, spec? */
4223   /* Also, convert back to Unix syntax if necessary. */
4224
4225   if (!mynam.naml$l_long_result_size) {
4226     if (isunix) {
4227       if (do_tounixspec(esa,outbuf,0) == NULL) {
4228         Safefree(esal);
4229         Safefree(esa);
4230         return NULL;
4231       }
4232     }
4233     else strcpy(outbuf,esa);
4234   }
4235   else if (isunix) {
4236     Newx(tmpfspec, VMS_MAXRSS, char);
4237     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4238         Safefree(esa);
4239         Safefree(esal);
4240         Safefree(tmpfspec);
4241         return NULL;
4242     }
4243     strcpy(outbuf,tmpfspec);
4244     Safefree(tmpfspec);
4245   }
4246
4247   mynam.naml$b_nop |= NAM$M_SYNCHK;
4248   mynam.naml$l_rlf = NULL;
4249   mynam.naml$l_rsa = NULL;
4250   mynam.naml$b_rss = 0;
4251   mynam.naml$l_long_result = NULL;
4252   mynam.naml$l_long_result_size = 0;
4253   myfab.fab$b_dns = 0;
4254   mynam.naml$l_long_defname_size = 0;
4255   sts = sys$parse(&myfab,0,0);  /* Free search context */
4256   Safefree(esa);
4257   Safefree(esal);
4258   return outbuf;
4259 }
4260 #endif
4261 /*}}}*/
4262 /* External entry points */
4263 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4264 { return do_rmsexpand(spec,buf,0,def,opt); }
4265 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4266 { return do_rmsexpand(spec,buf,1,def,opt); }
4267
4268
4269 /*
4270 ** The following routines are provided to make life easier when
4271 ** converting among VMS-style and Unix-style directory specifications.
4272 ** All will take input specifications in either VMS or Unix syntax. On
4273 ** failure, all return NULL.  If successful, the routines listed below
4274 ** return a pointer to a buffer containing the appropriately
4275 ** reformatted spec (and, therefore, subsequent calls to that routine
4276 ** will clobber the result), while the routines of the same names with
4277 ** a _ts suffix appended will return a pointer to a mallocd string
4278 ** containing the appropriately reformatted spec.
4279 ** In all cases, only explicit syntax is altered; no check is made that
4280 ** the resulting string is valid or that the directory in question
4281 ** actually exists.
4282 **
4283 **   fileify_dirspec() - convert a directory spec into the name of the
4284 **     directory file (i.e. what you can stat() to see if it's a dir).
4285 **     The style (VMS or Unix) of the result is the same as the style
4286 **     of the parameter passed in.
4287 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4288 **     what you prepend to a filename to indicate what directory it's in).
4289 **     The style (VMS or Unix) of the result is the same as the style
4290 **     of the parameter passed in.
4291 **   tounixpath() - convert a directory spec into a Unix-style path.
4292 **   tovmspath() - convert a directory spec into a VMS-style path.
4293 **   tounixspec() - convert any file spec into a Unix-style file spec.
4294 **   tovmsspec() - convert any file spec into a VMS-style spec.
4295 **
4296 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4297 ** Permission is given to distribute this code as part of the Perl
4298 ** standard distribution under the terms of the GNU General Public
4299 ** License or the Perl Artistic License.  Copies of each may be
4300 ** found in the Perl standard distribution.
4301  */
4302
4303 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
4304 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4305 {
4306     static char __fileify_retbuf[NAM$C_MAXRSS+1];
4307     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4308     char *retspec, *cp1, *cp2, *lastdir;
4309     char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
4310     unsigned short int trnlnm_iter_count;
4311     int sts;
4312
4313     if (!dir || !*dir) {
4314       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4315     }
4316     dirlen = strlen(dir);
4317     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4318     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4319       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4320         dir = "/sys$disk";
4321         dirlen = 9;
4322       }
4323       else
4324         dirlen = 1;
4325     }
4326     if (dirlen > NAM$C_MAXRSS) {
4327       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
4328     }
4329     if (!strpbrk(dir+1,"/]>:")  &&
4330         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4331       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4332       trnlnm_iter_count = 0;
4333       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4334         trnlnm_iter_count++;
4335         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4336       }
4337       dirlen = strlen(trndir);
4338     }
4339     else {
4340       strncpy(trndir,dir,dirlen);
4341       trndir[dirlen] = '\0';
4342     }
4343
4344     /* At this point we are done with *dir and use *trndir which is a
4345      * copy that can be modified.  *dir must not be modified.
4346      */
4347
4348     /* If we were handed a rooted logical name or spec, treat it like a
4349      * simple directory, so that
4350      *    $ Define myroot dev:[dir.]
4351      *    ... do_fileify_dirspec("myroot",buf,1) ...
4352      * does something useful.
4353      */
4354     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4355       trndir[--dirlen] = '\0';
4356       trndir[dirlen-1] = ']';
4357     }
4358     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4359       trndir[--dirlen] = '\0';
4360       trndir[dirlen-1] = '>';
4361     }
4362
4363     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4364       /* If we've got an explicit filename, we can just shuffle the string. */
4365       if (*(cp1+1)) hasfilename = 1;
4366       /* Similarly, we can just back up a level if we've got multiple levels
4367          of explicit directories in a VMS spec which ends with directories. */
4368       else {
4369         for (cp2 = cp1; cp2 > trndir; cp2--) {
4370           if (*cp2 == '.') {
4371             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4372               *cp2 = *cp1; *cp1 = '\0';
4373               hasfilename = 1;
4374               break;
4375             }
4376           }
4377           if (*cp2 == '[' || *cp2 == '<') break;
4378         }
4379       }
4380     }
4381
4382     cp1 = strpbrk(trndir,"]:>"); /* Prepare for future change */
4383     if (hasfilename || !cp1) { /* Unix-style path or filename */
4384       if (trndir[0] == '.') {
4385         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0'))
4386           return do_fileify_dirspec("[]",buf,ts);
4387         else if (trndir[1] == '.' &&
4388                  (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0')))
4389           return do_fileify_dirspec("[-]",buf,ts);
4390       }
4391       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4392         dirlen -= 1;                 /* to last element */
4393         lastdir = strrchr(trndir,'/');
4394       }
4395       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4396         /* If we have "/." or "/..", VMSify it and let the VMS code
4397          * below expand it, rather than repeating the code to handle
4398          * relative components of a filespec here */
4399         do {
4400           if (*(cp1+2) == '.') cp1++;
4401           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4402             if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
4403             if (strchr(vmsdir,'/') != NULL) {
4404               /* If do_tovmsspec() returned it, it must have VMS syntax
4405                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
4406                * the time to check this here only so we avoid a recursion
4407                * loop; otherwise, gigo.
4408                */
4409               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
4410             }
4411             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
4412             return do_tounixspec(trndir,buf,ts);
4413           }
4414           cp1++;
4415         } while ((cp1 = strstr(cp1,"/.")) != NULL);
4416         lastdir = strrchr(trndir,'/');
4417       }
4418       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4419         /* Ditto for specs that end in an MFD -- let the VMS code
4420          * figure out whether it's a real device or a rooted logical. */
4421
4422         /* This should not happen any more.  Allowing the fake /000000
4423          * in a UNIX pathname causes all sorts of problems when trying
4424          * to run in UNIX emulation.  So the VMS to UNIX conversions
4425          * now remove the fake /000000 directories.
4426          */
4427
4428         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4429         if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
4430         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
4431         return do_tounixspec(trndir,buf,ts);
4432       }
4433       else {
4434
4435         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4436              !(lastdir = cp1 = strrchr(trndir,']')) &&
4437              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4438         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
4439           int ver; char *cp3;
4440
4441           /* For EFS or ODS-5 look for the last dot */
4442           if (decc_efs_charset) {
4443               cp2 = strrchr(cp1,'.');
4444           }
4445           if (vms_process_case_tolerant) {
4446               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4447                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4448                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4449                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4450                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4451                             (ver || *cp3)))))) {
4452                   set_errno(ENOTDIR);
4453                   set_vaxc_errno(RMS$_DIR);
4454                   return NULL;
4455               }
4456           }
4457           else {
4458               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4459                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4460                   !*(cp2+3) || *(cp2+3) != 'R' ||
4461                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4462                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4463                             (ver || *cp3)))))) {
4464                  set_errno(ENOTDIR);
4465                  set_vaxc_errno(RMS$_DIR);
4466                  return NULL;
4467               }
4468           }
4469           dirlen = cp2 - trndir;
4470         }
4471       }
4472
4473       retlen = dirlen + 6;
4474       if (buf) retspec = buf;
4475       else if (ts) Newx(retspec,retlen+1,char);
4476       else retspec = __fileify_retbuf;
4477       memcpy(retspec,trndir,dirlen);
4478       retspec[dirlen] = '\0';
4479
4480       /* We've picked up everything up to the directory file name.
4481          Now just add the type and version, and we're set. */
4482       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4483         strcat(retspec,".dir;1");
4484       else
4485         strcat(retspec,".DIR;1");
4486       return retspec;
4487     }
4488     else {  /* VMS-style directory spec */
4489       char esa[NAM$C_MAXRSS+1], term, *cp;
4490       unsigned long int sts, cmplen, haslower = 0;
4491       struct FAB dirfab = cc$rms_fab;
4492       struct NAM savnam, dirnam = cc$rms_nam;
4493
4494       dirfab.fab$b_fns = strlen(trndir);
4495       dirfab.fab$l_fna = trndir;
4496       dirfab.fab$l_nam = &dirnam;
4497       dirfab.fab$l_dna = ".DIR;1";
4498       dirfab.fab$b_dns = 6;
4499       dirnam.nam$b_ess = NAM$C_MAXRSS;
4500       dirnam.nam$l_esa = esa;
4501 #ifdef NAM$M_NO_SHORT_UPCASE
4502       if (decc_efs_case_preserve)
4503         dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4504 #endif
4505
4506       for (cp = trndir; *cp; cp++)
4507         if (islower(*cp)) { haslower = 1; break; }
4508       if (!((sts = sys$parse(&dirfab))&1)) {
4509         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4510           dirnam.nam$b_nop |= NAM$M_SYNCHK;
4511           sts = sys$parse(&dirfab) & 1;
4512         }
4513         if (!sts) {
4514           set_errno(EVMSERR);
4515           set_vaxc_errno(dirfab.fab$l_sts);
4516           return NULL;
4517         }
4518       }
4519       else {
4520         savnam = dirnam;
4521         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
4522           /* Yes; fake the fnb bits so we'll check type below */
4523           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
4524         }
4525         else { /* No; just work with potential name */
4526           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4527           else {
4528             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
4529             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4530             dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4531             return NULL;
4532           }
4533         }
4534       }
4535       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4536         cp1 = strchr(esa,']');
4537         if (!cp1) cp1 = strchr(esa,'>');
4538         if (cp1) {  /* Should always be true */
4539           dirnam.nam$b_esl -= cp1 - esa - 1;
4540           memmove(esa,cp1 + 1,dirnam.nam$b_esl);
4541         }
4542       }
4543       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
4544         /* Yep; check version while we're at it, if it's there. */
4545         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
4546         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
4547           /* Something other than .DIR[;1].  Bzzt. */
4548           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4549           dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4550           set_errno(ENOTDIR);
4551           set_vaxc_errno(RMS$_DIR);
4552           return NULL;
4553         }
4554       }
4555       esa[dirnam.nam$b_esl] = '\0';
4556       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
4557         /* They provided at least the name; we added the type, if necessary, */
4558         if (buf) retspec = buf;                            /* in sys$parse() */
4559         else if (ts) Newx(retspec,dirnam.nam$b_esl+1,char);
4560         else retspec = __fileify_retbuf;
4561         strcpy(retspec,esa);
4562         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4563         dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4564         return retspec;
4565       }
4566       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4567         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4568         *cp1 = '\0';
4569         dirnam.nam$b_esl -= 9;
4570       }
4571       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4572       if (cp1 == NULL) { /* should never happen */
4573         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4574         dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4575         return NULL;
4576       }
4577       term = *cp1;
4578       *cp1 = '\0';
4579       retlen = strlen(esa);
4580       cp1 = strrchr(esa,'.');
4581       /* ODS-5 directory specifications can have extra "." in them. */
4582       while (cp1 != NULL) {
4583         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4584           break;
4585         else {
4586            cp1--;
4587            while ((cp1 > esa) && (*cp1 != '.'))
4588              cp1--;
4589         }
4590         if (cp1 == esa)
4591           cp1 = NULL;
4592       }
4593
4594       if ((cp1) != NULL) {
4595         /* There's more than one directory in the path.  Just roll back. */
4596         *cp1 = term;
4597         if (buf) retspec = buf;
4598         else if (ts) Newx(retspec,retlen+7,char);
4599         else retspec = __fileify_retbuf;
4600         strcpy(retspec,esa);
4601       }
4602       else {
4603         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
4604           /* Go back and expand rooted logical name */
4605           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
4606 #ifdef NAM$M_NO_SHORT_UPCASE
4607           if (decc_efs_case_preserve)
4608             dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4609 #endif
4610           if (!(sys$parse(&dirfab) & 1)) {
4611             dirnam.nam$l_rlf = NULL;
4612             dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4613             set_errno(EVMSERR);
4614             set_vaxc_errno(dirfab.fab$l_sts);
4615             return NULL;
4616           }
4617           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
4618           if (buf) retspec = buf;
4619           else if (ts) Newx(retspec,retlen+16,char);
4620           else retspec = __fileify_retbuf;
4621           cp1 = strstr(esa,"][");
4622           if (!cp1) cp1 = strstr(esa,"]<");
4623           dirlen = cp1 - esa;
4624           memcpy(retspec,esa,dirlen);
4625           if (!strncmp(cp1+2,"000000]",7)) {
4626             retspec[dirlen-1] = '\0';
4627             /* Not full ODS-5, just extra dots in directories for now */
4628             cp1 = retspec + dirlen - 1;
4629             while (cp1 > retspec)
4630             {
4631               if (*cp1 == '[')
4632                 break;
4633               if (*cp1 == '.') {
4634                 if (*(cp1-1) != '^')
4635                   break;
4636               }
4637               cp1--;
4638             }
4639             if (*cp1 == '.') *cp1 = ']';
4640             else {
4641               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4642               memmove(cp1+1,"000000]",7);
4643             }
4644           }
4645           else {
4646             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
4647             retspec[retlen] = '\0';
4648             /* Convert last '.' to ']' */
4649             cp1 = retspec+retlen-1;
4650             while (*cp != '[') {
4651               cp1--;
4652               if (*cp1 == '.') {
4653                 /* Do not trip on extra dots in ODS-5 directories */
4654                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
4655                 break;
4656               }
4657             }
4658             if (*cp1 == '.') *cp1 = ']';
4659             else {
4660               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4661               memmove(cp1+1,"000000]",7);
4662             }
4663           }
4664         }
4665         else {  /* This is a top-level dir.  Add the MFD to the path. */
4666           if (buf) retspec = buf;
4667           else if (ts) Newx(retspec,retlen+16,char);
4668           else retspec = __fileify_retbuf;
4669           cp1 = esa;
4670           cp2 = retspec;
4671           while (*cp1 != ':') *(cp2++) = *(cp1++);
4672           strcpy(cp2,":[000000]");
4673           cp1 += 2;
4674           strcpy(cp2+9,cp1);
4675         }
4676       }
4677       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4678       dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4679       /* We've set up the string up through the filename.  Add the
4680          type and version, and we're done. */
4681       strcat(retspec,".DIR;1");
4682
4683       /* $PARSE may have upcased filespec, so convert output to lower
4684        * case if input contained any lowercase characters. */
4685       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
4686       return retspec;
4687     }
4688 }  /* end of do_fileify_dirspec() */
4689 /*}}}*/
4690 /* External entry points */
4691 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
4692 { return do_fileify_dirspec(dir,buf,0); }
4693 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
4694 { return do_fileify_dirspec(dir,buf,1); }
4695
4696 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
4697 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
4698 {
4699     static char __pathify_retbuf[NAM$C_MAXRSS+1];
4700     unsigned long int retlen;
4701     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
4702     unsigned short int trnlnm_iter_count;
4703     STRLEN trnlen;
4704     int sts;
4705
4706     if (!dir || !*dir) {
4707       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4708     }
4709
4710     if (*dir) strcpy(trndir,dir);
4711     else getcwd(trndir,sizeof trndir - 1);
4712
4713     trnlnm_iter_count = 0;
4714     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
4715            && my_trnlnm(trndir,trndir,0)) {
4716       trnlnm_iter_count++;
4717       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4718       trnlen = strlen(trndir);
4719
4720       /* Trap simple rooted lnms, and return lnm:[000000] */
4721       if (!strcmp(trndir+trnlen-2,".]")) {
4722         if (buf) retpath = buf;
4723         else if (ts) Newx(retpath,strlen(dir)+10,char);
4724         else retpath = __pathify_retbuf;
4725         strcpy(retpath,dir);
4726         strcat(retpath,":[000000]");
4727         return retpath;
4728       }
4729     }
4730
4731     /* At this point we do not work with *dir, but the copy in
4732      * *trndir that is modifiable.
4733      */
4734
4735     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
4736       if (*trndir == '.' && (*(trndir+1) == '\0' ||
4737                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
4738         retlen = 2 + (*(trndir+1) != '\0');
4739       else {
4740         if ( !(cp1 = strrchr(trndir,'/')) &&
4741              !(cp1 = strrchr(trndir,']')) &&
4742              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
4743         if ((cp2 = strchr(cp1,'.')) != NULL &&
4744             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
4745              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
4746               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
4747               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
4748           int ver; char *cp3;
4749
4750           /* For EFS or ODS-5 look for the last dot */
4751           if (decc_efs_charset) {
4752             cp2 = strrchr(cp1,'.');
4753           }
4754           if (vms_process_case_tolerant) {
4755               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4756                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4757                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4758                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4759                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4760                             (ver || *cp3)))))) {
4761                 set_errno(ENOTDIR);
4762                 set_vaxc_errno(RMS$_DIR);
4763                 return NULL;
4764               }
4765           }
4766           else {
4767               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4768                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4769                   !*(cp2+3) || *(cp2+3) != 'R' ||
4770                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4771                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4772                             (ver || *cp3)))))) {
4773                 set_errno(ENOTDIR);
4774                 set_vaxc_errno(RMS$_DIR);
4775                 return NULL;
4776               }
4777           }
4778           retlen = cp2 - trndir + 1;
4779         }
4780         else {  /* No file type present.  Treat the filename as a directory. */
4781           retlen = strlen(trndir) + 1;
4782         }
4783       }
4784       if (buf) retpath = buf;
4785       else if (ts) Newx(retpath,retlen+1,char);
4786       else retpath = __pathify_retbuf;
4787       strncpy(retpath, trndir, retlen-1);
4788       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
4789         retpath[retlen-1] = '/';      /* with '/', add it. */
4790         retpath[retlen] = '\0';
4791       }
4792       else retpath[retlen-1] = '\0';
4793     }
4794     else {  /* VMS-style directory spec */
4795       char esa[NAM$C_MAXRSS+1], *cp;
4796       unsigned long int sts, cmplen, haslower;
4797       struct FAB dirfab = cc$rms_fab;
4798       struct NAM savnam, dirnam = cc$rms_nam;
4799
4800       /* If we've got an explicit filename, we can just shuffle the string. */
4801       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
4802              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
4803         if ((cp2 = strchr(cp1,'.')) != NULL) {
4804           int ver; char *cp3;
4805           if (vms_process_case_tolerant) {
4806               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
4807                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
4808                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4809                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4810                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4811                             (ver || *cp3)))))) {
4812                set_errno(ENOTDIR);
4813                set_vaxc_errno(RMS$_DIR);
4814                return NULL;
4815              }
4816           }
4817           else {
4818               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
4819                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
4820                   !*(cp2+3) || *(cp2+3) != 'R' ||
4821                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
4822                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4823                             (ver || *cp3)))))) {
4824                set_errno(ENOTDIR);
4825                set_vaxc_errno(RMS$_DIR);
4826                return NULL;
4827              }
4828           }
4829         }
4830         else {  /* No file type, so just draw name into directory part */
4831           for (cp2 = cp1; *cp2; cp2++) ;
4832         }
4833         *cp2 = *cp1;
4834         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
4835         *cp1 = '.';
4836         /* We've now got a VMS 'path'; fall through */
4837       }
4838       dirfab.fab$b_fns = strlen(trndir);
4839       dirfab.fab$l_fna = trndir;
4840       if (trndir[dirfab.fab$b_fns-1] == ']' ||
4841           trndir[dirfab.fab$b_fns-1] == '>' ||
4842           trndir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
4843         if (buf) retpath = buf;
4844         else if (ts) Newx(retpath,strlen(trndir)+1,char);
4845         else retpath = __pathify_retbuf;
4846         strcpy(retpath,trndir);
4847         return retpath;
4848       }
4849       dirfab.fab$l_dna = ".DIR;1";
4850       dirfab.fab$b_dns = 6;
4851       dirfab.fab$l_nam = &dirnam;
4852       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
4853       dirnam.nam$l_esa = esa;
4854 #ifdef NAM$M_NO_SHORT_UPCASE
4855       if (decc_efs_case_preserve)
4856           dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4857 #endif
4858
4859       for (cp = trndir; *cp; cp++)
4860         if (islower(*cp)) { haslower = 1; break; }
4861
4862       if (!(sts = (sys$parse(&dirfab)&1))) {
4863         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4864           dirnam.nam$b_nop |= NAM$M_SYNCHK;
4865           sts = sys$parse(&dirfab) & 1;
4866         }
4867         if (!sts) {
4868           set_errno(EVMSERR);
4869           set_vaxc_errno(dirfab.fab$l_sts);
4870           return NULL;
4871         }
4872       }
4873       else {
4874         savnam = dirnam;
4875         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
4876           if (dirfab.fab$l_sts != RMS$_FNF) {
4877             int sts1;
4878             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4879             dirfab.fab$b_dns = 0;
4880             sts1 = sys$parse(&dirfab,0,0);
4881             set_errno(EVMSERR);
4882             set_vaxc_errno(dirfab.fab$l_sts);
4883             return NULL;
4884           }
4885           dirnam = savnam; /* No; just work with potential name */
4886         }
4887       }
4888       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
4889         /* Yep; check version while we're at it, if it's there. */
4890         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
4891         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
4892           int sts2;
4893           /* Something other than .DIR[;1].  Bzzt. */
4894           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4895           dirfab.fab$b_dns = 0;
4896           sts2 = sys$parse(&dirfab,0,0);
4897           set_errno(ENOTDIR);
4898           set_vaxc_errno(RMS$_DIR);
4899           return NULL;
4900         }
4901       }
4902       /* OK, the type was fine.  Now pull any file name into the
4903          directory path. */
4904       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
4905       else {
4906         cp1 = strrchr(esa,'>');
4907         *dirnam.nam$l_type = '>';
4908       }
4909       *cp1 = '.';
4910       *(dirnam.nam$l_type + 1) = '\0';
4911       retlen = dirnam.nam$l_type - esa + 2;
4912       if (buf) retpath = buf;
4913       else if (ts) Newx(retpath,retlen,char);
4914       else retpath = __pathify_retbuf;
4915       strcpy(retpath,esa);
4916       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
4917       dirfab.fab$b_dns = 0;  sts = sys$parse(&dirfab,0,0);
4918       /* $PARSE may have upcased filespec, so convert output to lower
4919        * case if input contained any lowercase characters. */
4920       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
4921     }
4922
4923     return retpath;
4924 }  /* end of do_pathify_dirspec() */
4925 /*}}}*/
4926 /* External entry points */
4927 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
4928 { return do_pathify_dirspec(dir,buf,0); }
4929 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
4930 { return do_pathify_dirspec(dir,buf,1); }
4931
4932 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
4933 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
4934 {
4935   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
4936   char *dirend, *rslt, *cp1, *cp3, tmp[NAM$C_MAXRSS+1];
4937   const char *cp2;
4938   int devlen, dirlen, retlen = NAM$C_MAXRSS+1;
4939   int expand = 1; /* guarantee room for leading and trailing slashes */
4940   unsigned short int trnlnm_iter_count;
4941   int cmp_rslt;
4942
4943   if (spec == NULL) return NULL;
4944   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
4945   if (buf) rslt = buf;
4946   else if (ts) {
4947     retlen = strlen(spec);
4948     cp1 = strchr(spec,'[');
4949     if (!cp1) cp1 = strchr(spec,'<');
4950     if (cp1) {
4951       for (cp1++; *cp1; cp1++) {
4952         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
4953         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
4954           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
4955       }
4956     }
4957     Newx(rslt,retlen+2+2*expand,char);
4958   }
4959   else rslt = __tounixspec_retbuf;
4960
4961   /* New VMS specific format needs translation
4962    * glob passes filenames with trailing '\n' and expects this preserved.
4963    */
4964   if (decc_posix_compliant_pathnames) {
4965     if (strncmp(spec, "\"^UP^", 5) == 0) {
4966       char * uspec;
4967       char *tunix;
4968       int tunix_len;
4969       int nl_flag;
4970
4971       Newx(tunix, VMS_MAXRSS + 1,char);
4972       strcpy(tunix, spec);
4973       tunix_len = strlen(tunix);
4974       nl_flag = 0;
4975       if (tunix[tunix_len - 1] == '\n') {
4976         tunix[tunix_len - 1] = '\"';
4977         tunix[tunix_len] = '\0';
4978         tunix_len--;
4979         nl_flag = 1;
4980       }
4981       uspec = decc$translate_vms(tunix);
4982       Safefree(tunix);
4983       if ((int)uspec > 0) {
4984         strcpy(rslt,uspec);
4985         if (nl_flag) {
4986           strcat(rslt,"\n");
4987         }
4988         else {
4989           /* If we can not translate it, makemaker wants as-is */
4990           strcpy(rslt, spec);
4991         }
4992         return rslt;
4993       }
4994     }
4995   }
4996
4997   cmp_rslt = 0; /* Presume VMS */
4998   cp1 = strchr(spec, '/');
4999   if (cp1 == NULL)
5000     cmp_rslt = 0;
5001
5002     /* Look for EFS ^/ */
5003     if (decc_efs_charset) {
5004       while (cp1 != NULL) {
5005         cp2 = cp1 - 1;
5006         if (*cp2 != '^') {
5007           /* Found illegal VMS, assume UNIX */
5008           cmp_rslt = 1;
5009           break;
5010         }
5011       cp1++;
5012       cp1 = strchr(cp1, '/');
5013     }
5014   }
5015
5016   /* Look for "." and ".." */
5017   if (decc_filename_unix_report) {
5018     if (spec[0] == '.') {
5019       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5020         cmp_rslt = 1;
5021       }
5022       else {
5023         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5024           cmp_rslt = 1;
5025         }
5026       }
5027     }
5028   }
5029   /* This is already UNIX or at least nothing VMS understands */
5030   if (cmp_rslt) {
5031     strcpy(rslt,spec);
5032     return rslt;
5033   }
5034
5035   cp1 = rslt;
5036   cp2 = spec;
5037   dirend = strrchr(spec,']');
5038   if (dirend == NULL) dirend = strrchr(spec,'>');
5039   if (dirend == NULL) dirend = strchr(spec,':');
5040   if (dirend == NULL) {
5041     strcpy(rslt,spec);
5042     return rslt;
5043   }
5044
5045   /* Special case 1 - sys$posix_root = / */
5046 #if __CRTL_VER >= 70000000
5047   if (!decc_disable_posix_root) {
5048     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5049       *cp1 = '/';
5050       cp1++;
5051       cp2 = cp2 + 15;
5052       }
5053   }
5054 #endif
5055
5056   /* Special case 2 - Convert NLA0: to /dev/null */
5057 #if __CRTL_VER < 70000000
5058   cmp_rslt = strncmp(spec,"NLA0:", 5);
5059   if (cmp_rslt != 0)
5060      cmp_rslt = strncmp(spec,"nla0:", 5);
5061 #else
5062   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5063 #endif
5064   if (cmp_rslt == 0) {
5065     strcpy(rslt, "/dev/null");
5066     cp1 = cp1 + 9;
5067     cp2 = cp2 + 5;
5068     if (spec[6] != '\0') {
5069       cp1[9] == '/';
5070       cp1++;
5071       cp2++;
5072     }
5073   }
5074
5075    /* Also handle special case "SYS$SCRATCH:" */
5076 #if __CRTL_VER < 70000000
5077   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5078   if (cmp_rslt != 0)
5079      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5080 #else
5081   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5082 #endif
5083   if (cmp_rslt == 0) {
5084   int islnm;
5085
5086     islnm = my_trnlnm(tmp, "TMP", 0);
5087     if (!islnm) {
5088       strcpy(rslt, "/tmp");
5089       cp1 = cp1 + 4;
5090       cp2 = cp2 + 12;
5091       if (spec[12] != '\0') {
5092         cp1[4] == '/';
5093         cp1++;
5094         cp2++;
5095       }
5096     }
5097   }
5098
5099   if (*cp2 != '[' && *cp2 != '<') {
5100     *(cp1++) = '/';
5101   }
5102   else {  /* the VMS spec begins with directories */
5103     cp2++;
5104     if (*cp2 == ']' || *cp2 == '>') {
5105       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5106       return rslt;
5107     }
5108     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5109       if (getcwd(tmp,sizeof tmp,1) == NULL) {
5110         if (ts) Safefree(rslt);
5111         return NULL;
5112       }
5113       trnlnm_iter_count = 0;
5114       do {
5115         cp3 = tmp;
5116         while (*cp3 != ':' && *cp3) cp3++;
5117         *(cp3++) = '\0';
5118         if (strchr(cp3,']') != NULL) break;
5119         trnlnm_iter_count++;
5120         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5121       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5122       if (ts && !buf &&
5123           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5124         retlen = devlen + dirlen;
5125         Renew(rslt,retlen+1+2*expand,char);
5126         cp1 = rslt;
5127       }
5128       cp3 = tmp;
5129       *(cp1++) = '/';
5130       while (*cp3) {
5131         *(cp1++) = *(cp3++);
5132         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
5133       }
5134       *(cp1++) = '/';
5135     }
5136     if ((*cp2 == '^')) {
5137         /* EFS file escape, pass the next character as is */
5138         /* Fix me: HEX encoding for UNICODE not implemented */
5139         cp2++;
5140     }
5141     else if ( *cp2 == '.') {
5142       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5143         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5144         cp2 += 3;
5145       }
5146       else cp2++;
5147     }
5148   }
5149   for (; cp2 <= dirend; cp2++) {
5150     if ((*cp2 == '^')) {
5151         /* EFS file escape, pass the next character as is */
5152         /* Fix me: HEX encoding for UNICODE not implemented */
5153         cp2++;
5154         *(cp1++) = *cp2;
5155     }
5156     if (*cp2 == ':') {
5157       *(cp1++) = '/';
5158       if (*(cp2+1) == '[') cp2++;
5159     }
5160     else if (*cp2 == ']' || *cp2 == '>') {
5161       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5162     }
5163     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5164       *(cp1++) = '/';
5165       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5166         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5167                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5168         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5169             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5170       }
5171       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5172         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5173         cp2 += 2;
5174       }
5175     }
5176     else if (*cp2 == '-') {
5177       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5178         while (*cp2 == '-') {
5179           cp2++;
5180           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5181         }
5182         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5183           if (ts) Safefree(rslt);                        /* filespecs like */
5184           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5185           return NULL;
5186         }
5187       }
5188       else *(cp1++) = *cp2;
5189     }
5190     else *(cp1++) = *cp2;
5191   }
5192   while (*cp2) *(cp1++) = *(cp2++);
5193   *cp1 = '\0';
5194
5195   /* This still leaves /000000/ when working with a
5196    * VMS device root or concealed root.
5197    */
5198   {
5199   int ulen;
5200   char * zeros;
5201
5202       ulen = strlen(rslt);
5203
5204       /* Get rid of "000000/ in rooted filespecs */
5205       if (ulen > 7) {
5206         zeros = strstr(rslt, "/000000/");
5207         if (zeros != NULL) {
5208           int mlen;
5209           mlen = ulen - (zeros - rslt) - 7;
5210           memmove(zeros, &zeros[7], mlen);
5211           ulen = ulen - 7;
5212           rslt[ulen] = '\0';
5213         }
5214       }
5215   }
5216
5217   return rslt;
5218
5219 }  /* end of do_tounixspec() */
5220 /*}}}*/
5221 /* External entry points */
5222 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5223 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5224
5225 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5226
5227 static int posix_to_vmsspec
5228   (char *vmspath, int vmspath_len, const char *unixpath) {
5229 int sts;
5230 struct FAB myfab = cc$rms_fab;
5231 struct NAML mynam = cc$rms_naml;
5232 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5233  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5234 char *esa;
5235 char *vms_delim;
5236 int dir_flag;
5237 int unixlen;
5238
5239   /* If not a posix spec already, convert it */
5240   dir_flag = 0;
5241   unixlen = strlen(unixpath);
5242   if (unixlen == 0) {
5243     vmspath[0] = '\0';
5244     return SS$_NORMAL;
5245   }
5246   if (strncmp(unixpath,"\"^UP^",5) != 0) {
5247     sprintf(vmspath,"\"^UP^%s\"",unixpath);
5248   }
5249   else {
5250     /* This is already a VMS specification, no conversion */
5251     unixlen--;
5252     strncpy(vmspath,unixpath, vmspath_len);
5253   }
5254   vmspath[vmspath_len] = 0;
5255   if (unixpath[unixlen - 1] == '/')
5256   dir_flag = 1;
5257   Newx(esa, VMS_MAXRSS+1, char);
5258   myfab.fab$l_fna = vmspath;
5259   myfab.fab$b_fns = strlen(vmspath);
5260   myfab.fab$l_naml = &mynam;
5261   mynam.naml$l_esa = NULL;
5262   mynam.naml$b_ess = 0;
5263   mynam.naml$l_long_expand = esa;
5264   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS;
5265   mynam.naml$l_rsa = NULL;
5266   mynam.naml$b_rss = 0;
5267   if (decc_efs_case_preserve)
5268     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5269   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5270
5271   /* Set up the remaining naml fields */
5272   sts = sys$parse(&myfab);
5273
5274   /* It failed! Try again as a UNIX filespec */
5275   if (!(sts & 1)) {
5276     Safefree(esa);
5277     return sts;
5278   }
5279
5280    /* get the Device ID and the FID */
5281    sts = sys$search(&myfab);
5282    /* on any failure, returned the POSIX ^UP^ filespec */
5283    if (!(sts & 1)) {
5284       Safefree(esa);
5285       return sts;
5286    }
5287    specdsc.dsc$a_pointer = vmspath;
5288    specdsc.dsc$w_length = vmspath_len;
5289
5290    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5291    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5292    sts = lib$fid_to_name
5293       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5294
5295   /* on any failure, returned the POSIX ^UP^ filespec */
5296   if (!(sts & 1)) {
5297      /* This can happen if user does not have permission to read directories */
5298      if (strncmp(unixpath,"\"^UP^",5) != 0)
5299        sprintf(vmspath,"\"^UP^%s\"",unixpath);
5300      else
5301        strcpy(vmspath, unixpath);
5302   }
5303   else {
5304     vmspath[specdsc.dsc$w_length] = 0;
5305
5306     /* Are we expecting a directory? */
5307     if (dir_flag != 0) {
5308     int i;
5309     char *eptr;
5310
5311       eptr = NULL;
5312
5313       i = specdsc.dsc$w_length - 1;
5314       while (i > 0) {
5315       int zercnt;
5316         zercnt = 0;
5317         /* Version must be '1' */
5318         if (vmspath[i--] != '1')
5319           break;
5320         /* Version delimiter is one of ".;" */
5321         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5322           break;
5323         i--;
5324         if (vmspath[i--] != 'R')
5325           break;
5326         if (vmspath[i--] != 'I')
5327           break;
5328         if (vmspath[i--] != 'D')
5329           break;
5330         if (vmspath[i--] != '.')
5331           break;
5332         eptr = &vmspath[i+1];
5333         while (i > 0) {
5334           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5335             if (vmspath[i-1] != '^') {
5336               if (zercnt != 6) {
5337                 *eptr = vmspath[i];
5338                 eptr[1] = '\0';
5339                 vmspath[i] = '.';
5340                 break;
5341               }
5342               else {
5343                 /* Get rid of 6 imaginary zero directory filename */
5344                 vmspath[i+1] = '\0';
5345               }
5346             }
5347           }
5348           if (vmspath[i] == '0')
5349             zercnt++;
5350           else
5351             zercnt = 10;
5352           i--;
5353         }
5354         break;
5355       }
5356     }
5357   }
5358   Safefree(esa);
5359   return sts;
5360 }
5361
5362 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5363 static int posix_to_vmsspec_hardway
5364   (char *vmspath, int vmspath_len, const char *unixpath) {
5365
5366 char *esa;
5367 const char *unixptr;
5368 char *vmsptr;
5369 const char *lastslash;
5370 const char *lastdot;
5371 int unixlen;
5372 int vmslen;
5373 int dir_start;
5374 int dir_dot;
5375 int quoted;
5376
5377
5378   unixptr = unixpath;
5379   dir_dot = 0;
5380
5381   /* Ignore leading "/" characters */
5382   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5383     unixptr++;
5384   }
5385   unixlen = strlen(unixptr);
5386
5387   /* Do nothing with blank paths */
5388   if (unixlen == 0) {
5389     vmspath[0] = '\0';
5390     return SS$_NORMAL;
5391   }
5392
5393   lastslash = strrchr(unixptr,'/');
5394   lastdot = strrchr(unixptr,'.');
5395
5396
5397   /* last dot is last dot or past end of string */
5398   if (lastdot == NULL)
5399     lastdot = unixptr + unixlen;
5400
5401   /* if no directories, set last slash to beginning of string */
5402   if (lastslash == NULL) {
5403     lastslash = unixptr;
5404   }
5405   else {
5406     /* Watch out for trailing "." after last slash, still a directory */
5407     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5408       lastslash = unixptr + unixlen;
5409     }
5410
5411     /* Watch out for traiing ".." after last slash, still a directory */
5412     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5413       lastslash = unixptr + unixlen;
5414     }
5415
5416     /* dots in directories are aways escaped */
5417     if (lastdot < lastslash)
5418       lastdot = unixptr + unixlen;
5419   }
5420
5421   /* if (unixptr < lastslash) then we are in a directory */
5422
5423   dir_start = 0;
5424   quoted = 0;
5425
5426   vmsptr = vmspath;
5427   vmslen = 0;
5428
5429   /* This could have a "^UP^ on the front */
5430   if (strncmp(unixptr,"\"^UP^",5) == 0) {
5431     quoted = 1;
5432     unixptr+= 5;
5433   }
5434
5435   /* Start with the UNIX path */
5436   if (*unixptr != '/') {
5437     /* relative paths */
5438     if (lastslash > unixptr) {
5439     int dotdir_seen;
5440
5441       /* skip leading ./ */
5442       dotdir_seen = 0;
5443       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5444         dotdir_seen = 1;
5445         unixptr++;
5446         unixptr++;
5447       }
5448
5449       /* Are we still in a directory? */
5450       if (unixptr <= lastslash) {
5451         *vmsptr++ = '[';
5452         vmslen = 1;
5453         dir_start = 1;
5454
5455         /* if not backing up, then it is relative forward. */
5456         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5457               ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5458           *vmsptr++ = '.';
5459           vmslen++;
5460           dir_dot = 1;
5461         }
5462        }
5463        else {
5464          if (dotdir_seen) {
5465            /* Perl wants an empty directory here to tell the difference
5466             * between a DCL commmand and a filename
5467             */
5468           *vmsptr++ = '[';
5469           *vmsptr++ = ']';
5470           vmslen = 2;
5471         }
5472       }
5473     }
5474     else {
5475       /* Handle two special files . and .. */
5476       if (unixptr[0] == '.') {
5477         if (unixptr[1] == '\0') {
5478           *vmsptr++ = '[';
5479           *vmsptr++ = ']';
5480           vmslen += 2;
5481           *vmsptr++ = '\0';
5482           return SS$_NORMAL;
5483         }
5484         if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5485           *vmsptr++ = '[';
5486           *vmsptr++ = '-';
5487           *vmsptr++ = ']';
5488           vmslen += 3;
5489           *vmsptr++ = '\0';
5490           return SS$_NORMAL;
5491         }
5492       }
5493     }
5494   }
5495   else {        /* Absolute PATH handling */
5496   int sts;
5497   char * nextslash;
5498   int seg_len;
5499     /* Need to find out where root is */
5500
5501     /* In theory, this procedure should never get an absolute POSIX pathname
5502      * that can not be found on the POSIX root.
5503      * In practice, that can not be relied on, and things will show up
5504      * here that are a VMS device name or concealed logical name instead.
5505      * So to make things work, this procedure must be tolerant.
5506      */
5507     Newx(esa, vmspath_len, char);
5508
5509     sts = SS$_NORMAL;
5510     nextslash = strchr(&unixptr[1],'/');
5511     seg_len = 0;
5512     if (nextslash != NULL) {
5513       seg_len = nextslash - &unixptr[1];
5514       strncpy(vmspath, unixptr, seg_len + 1);
5515       vmspath[seg_len+1] = 0;
5516       sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5517     }
5518
5519     if (sts & 1) {
5520       /* This is verified to be a real path */
5521
5522       sts = posix_to_vmsspec(esa, vmspath_len, "/");
5523       strcpy(vmspath, esa);
5524       vmslen = strlen(vmspath);
5525       vmsptr = vmspath + vmslen;
5526       unixptr++;
5527       if (unixptr < lastslash) {
5528       char * rptr;
5529         vmsptr--;
5530         *vmsptr++ = '.';
5531         dir_start = 1;
5532         dir_dot = 1;
5533         if (vmslen > 7) {
5534         int cmp;
5535           rptr = vmsptr - 7;
5536           cmp = strcmp(rptr,"000000.");
5537           if (cmp == 0) {
5538             vmslen -= 7;
5539             vmsptr -= 7;
5540             vmsptr[1] = '\0';
5541           } /* removing 6 zeros */
5542         } /* vmslen < 7, no 6 zeros possible */
5543       } /* Not in a directory */
5544     } /* end of verified real path handling */
5545     else {
5546     int add_6zero;
5547     int islnm;
5548
5549       /* Ok, we have a device or a concealed root that is not in POSIX
5550        * or we have garbage.  Make the best of it.
5551        */
5552
5553       /* Posix to VMS destroyed this, so copy it again */
5554       strncpy(vmspath, &unixptr[1], seg_len);
5555       vmspath[seg_len] = 0;
5556       vmslen = seg_len;
5557       vmsptr = &vmsptr[vmslen];
5558       islnm = 0;
5559
5560       /* Now do we need to add the fake 6 zero directory to it? */
5561       add_6zero = 1;
5562       if ((*lastslash == '/') && (nextslash < lastslash)) {
5563         /* No there is another directory */
5564         add_6zero = 0;
5565       }
5566       else {
5567       int trnend;
5568
5569         /* now we have foo:bar or foo:[000000]bar to decide from */
5570         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
5571         trnend = islnm ? islnm - 1 : 0;
5572
5573         /* if this was a logical name, ']' or '>' must be present */
5574         /* if not a logical name, then assume a device and hope. */
5575         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
5576
5577         /* if log name and trailing '.' then rooted - treat as device */
5578         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
5579
5580         /* Fix me, if not a logical name, a device lookup should be
5581          * done to see if the device is file structured.  If the device
5582          * is not file structured, the 6 zeros should not be put on.
5583          *
5584          * As it is, perl is occasionally looking for dev:[000000]tty.
5585          * which looks a little strange.
5586          */
5587
5588         if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
5589           /* No real directory present */
5590           add_6zero = 1;
5591         }
5592       }
5593
5594       /* Put the device delimiter on */
5595       *vmsptr++ = ':';
5596       vmslen++;
5597       unixptr = nextslash;
5598       unixptr++;
5599
5600       /* Start directory if needed */
5601       if (!islnm || add_6zero) {
5602         *vmsptr++ = '[';
5603         vmslen++;
5604         dir_start = 1;
5605       }
5606
5607       /* add fake 000000] if needed */
5608       if (add_6zero) {
5609         *vmsptr++ = '0';
5610         *vmsptr++ = '0';
5611         *vmsptr++ = '0';
5612         *vmsptr++ = '0';
5613         *vmsptr++ = '0';
5614         *vmsptr++ = '0';
5615         *vmsptr++ = ']';
5616         vmslen += 7;
5617         dir_start = 0;
5618       }
5619
5620     } /* non-POSIX translation */
5621     Safefree(esa);
5622   } /* End of relative/absolute path handling */
5623
5624   while ((*unixptr) && (vmslen < vmspath_len)){
5625   int dash_flag;
5626
5627     dash_flag = 0;
5628
5629     if (dir_start != 0) {
5630
5631       /* First characters in a directory are handled special */
5632       while ((*unixptr == '/') ||
5633              ((*unixptr == '.') &&
5634               ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
5635       int loop_flag;
5636
5637         loop_flag = 0;
5638
5639         /* Skip redundant / in specification */
5640         while ((*unixptr == '/') && (dir_start != 0)) {
5641           loop_flag = 1;
5642           unixptr++;
5643           if (unixptr == lastslash)
5644             break;
5645         }
5646         if (unixptr == lastslash)
5647           break;
5648
5649         /* Skip redundant ./ characters */
5650         while ((*unixptr == '.') &&
5651                ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
5652           loop_flag = 1;
5653           unixptr++;
5654           if (unixptr == lastslash)
5655             break;
5656           if (*unixptr == '/')
5657             unixptr++;
5658         }
5659         if (unixptr == lastslash)
5660           break;
5661
5662         /* Skip redundant ../ characters */
5663         while ((*unixptr == '.') && (unixptr[1] == '.') &&
5664              ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
5665           /* Set the backing up flag */
5666           loop_flag = 1;
5667           dir_dot = 0;
5668           dash_flag = 1;
5669           *vmsptr++ = '-';
5670           vmslen++;
5671           unixptr++; /* first . */
5672           unixptr++; /* second . */
5673           if (unixptr == lastslash)
5674             break;
5675           if (*unixptr == '/') /* The slash */
5676             unixptr++;
5677         }
5678         if (unixptr == lastslash)
5679           break;
5680
5681         /* To do: Perl expects /.../ to be translated to [...] on VMS */
5682         /* Not needed when VMS is pretending to be UNIX. */
5683
5684         /* Is this loop stuck because of too many dots? */
5685         if (loop_flag == 0) {
5686           /* Exit the loop and pass the rest through */
5687           break;
5688         }
5689       }
5690
5691       /* Are we done with directories yet? */
5692       if (unixptr >= lastslash) {
5693
5694         /* Watch out for trailing dots */
5695         if (dir_dot != 0) {
5696             vmslen --;
5697             vmsptr--;
5698         }
5699         *vmsptr++ = ']';
5700         vmslen++;
5701         dash_flag = 0;
5702         dir_start = 0;
5703         if (*unixptr == '/')
5704           unixptr++;
5705       }
5706       else {
5707         /* Have we stopped backing up? */
5708         if (dash_flag) {
5709           *vmsptr++ = '.';
5710           vmslen++;
5711           dash_flag = 0;
5712           /* dir_start continues to be = 1 */
5713         }
5714         if (*unixptr == '-') {
5715           *vmsptr++ = '^';
5716           *vmsptr++ = *unixptr++;
5717           vmslen += 2;
5718           dir_start = 0;
5719
5720           /* Now are we done with directories yet? */
5721           if (unixptr >= lastslash) {
5722
5723             /* Watch out for trailing dots */
5724             if (dir_dot != 0) {
5725               vmslen --;
5726               vmsptr--;
5727             }
5728
5729             *vmsptr++ = ']';
5730             vmslen++;
5731             dash_flag = 0;
5732             dir_start = 0;
5733           }
5734         }
5735       }
5736     }
5737
5738     /* All done? */
5739     if (*unixptr == '\0')
5740       break;
5741
5742     /* Normal characters - More EFS work probably needed */
5743     dir_start = 0;
5744     dir_dot = 0;
5745
5746     switch(*unixptr) {
5747     case '/':
5748         /* remove multiple / */
5749         while (unixptr[1] == '/') {
5750            unixptr++;
5751         }
5752         if (unixptr == lastslash) {
5753           /* Watch out for trailing dots */
5754           if (dir_dot != 0) {
5755             vmslen --;
5756             vmsptr--;
5757           }
5758           *vmsptr++ = ']';
5759         }
5760         else {
5761           dir_start = 1;
5762           *vmsptr++ = '.';
5763           dir_dot = 1;
5764
5765           /* To do: Perl expects /.../ to be translated to [...] on VMS */
5766           /* Not needed when VMS is pretending to be UNIX. */
5767
5768         }
5769         dash_flag = 0;
5770         if (*unixptr != '\0')
5771           unixptr++;
5772         vmslen++;
5773         break;
5774     case '?':
5775         *vmsptr++ = '%';
5776         vmslen++;
5777         unixptr++;
5778         break;
5779     case ' ':
5780         *vmsptr++ = '^';
5781         *vmsptr++ = '_';
5782         vmslen += 2;
5783         unixptr++;
5784         break;
5785     case '.':
5786         if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
5787           *vmsptr++ = '^';
5788           *vmsptr++ = '.';
5789           vmslen += 2;
5790           unixptr++;
5791
5792           /* trailing dot ==> '^..' on VMS */
5793           if (*unixptr == '\0') {
5794             *vmsptr++ = '.';
5795             vmslen++;
5796           }
5797           *vmsptr++ = *unixptr++;
5798           vmslen ++;
5799         }
5800         if (quoted && (unixptr[1] == '\0')) {
5801           unixptr++;
5802           break;
5803         }
5804         *vmsptr++ = '^';
5805         *vmsptr++ = *unixptr++;
5806         vmslen += 2;
5807         break;
5808     case '~':
5809     case ';':
5810     case '\\':
5811         *vmsptr++ = '^';
5812         *vmsptr++ = *unixptr++;
5813         vmslen += 2;
5814         break;
5815     default:
5816         if (*unixptr != '\0') {
5817           *vmsptr++ = *unixptr++;
5818           vmslen++;
5819         }
5820         break;
5821     }
5822   }
5823
5824   /* Make sure directory is closed */
5825   if (unixptr == lastslash) {
5826     char *vmsptr2;
5827     vmsptr2 = vmsptr - 1;
5828
5829     if (*vmsptr2 != ']') {
5830       *vmsptr2--;
5831
5832       /* directories do not end in a dot bracket */
5833       if (*vmsptr2 == '.') {
5834         vmsptr2--;
5835
5836         /* ^. is allowed */
5837         if (*vmsptr2 != '^') {
5838           vmsptr--; /* back up over the dot */
5839         }
5840       }
5841       *vmsptr++ = ']';
5842     }
5843   }
5844   else {
5845     char *vmsptr2;
5846     /* Add a trailing dot if a file with no extension */
5847     vmsptr2 = vmsptr - 1;
5848     if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
5849         (*lastdot != '.')) {
5850         *vmsptr++ = '.';
5851         vmslen++;
5852     }
5853   }
5854
5855   *vmsptr = '\0';
5856   return SS$_NORMAL;
5857 }
5858 #endif
5859
5860 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
5861 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
5862   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
5863   char *rslt, *dirend;
5864   char *lastdot;
5865   char *vms_delim;
5866   register char *cp1;
5867   const char *cp2;
5868   unsigned long int infront = 0, hasdir = 1;
5869   int rslt_len;
5870   int no_type_seen;
5871
5872   if (path == NULL) return NULL;
5873   rslt_len = VMS_MAXRSS;
5874   if (buf) rslt = buf;
5875   else if (ts) Newx(rslt,NAM$C_MAXRSS+1,char);
5876   else rslt = __tovmsspec_retbuf;
5877   if (strpbrk(path,"]:>") ||
5878       (dirend = strrchr(path,'/')) == NULL) {
5879     if (path[0] == '.') {
5880       if (path[1] == '\0') strcpy(rslt,"[]");
5881       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
5882       else strcpy(rslt,path); /* probably garbage */
5883     }
5884     else strcpy(rslt,path);
5885     return rslt;
5886   }
5887
5888    /* Posix specifications are now a native VMS format */
5889   /*--------------------------------------------------*/
5890 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5891   if (decc_posix_compliant_pathnames) {
5892     if (strncmp(path,"\"^UP^",5) == 0) {
5893       posix_to_vmsspec_hardway(rslt, rslt_len, path);
5894       return rslt;
5895     }
5896   }
5897 #endif
5898
5899   vms_delim = strpbrk(path,"]:>");
5900
5901   if ((vms_delim != NULL) ||
5902       ((dirend = strrchr(path,'/')) == NULL)) {
5903
5904     /* VMS special characters found! */
5905
5906     if (path[0] == '.') {
5907       if (path[1] == '\0') strcpy(rslt,"[]");
5908       else if (path[1] == '.' && path[2] == '\0')
5909         strcpy(rslt,"[-]");
5910
5911       /* Dot preceeding a device or directory ? */
5912       else {
5913         /* If not in POSIX mode, pass it through and hope it works */
5914 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5915         if (!decc_posix_compliant_pathnames)
5916           strcpy(rslt,path); /* probably garbage */
5917         else
5918           posix_to_vmsspec_hardway(rslt, rslt_len, path);
5919 #else
5920         strcpy(rslt,path); /* probably garbage */
5921 #endif
5922       }
5923     }
5924     else {
5925
5926        /* If no VMS characters and in POSIX mode, convert it!
5927         * This is the easiest way to get directory specifications
5928         * handled correctly in POSIX mode
5929         */
5930 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5931       if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
5932         posix_to_vmsspec_hardway(rslt, rslt_len, path);
5933       else {
5934         /* No unix path separators - presume VMS already */
5935         strcpy(rslt,path);
5936       }
5937 #else
5938       strcpy(rslt,path); /* probably garbage */
5939 #endif
5940     }
5941     return rslt;
5942   }
5943
5944 /* If POSIX mode active, handle the conversion */
5945 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5946   if (decc_posix_compliant_pathnames) {
5947     posix_to_vmsspec_hardway(rslt, rslt_len, path);
5948     return rslt;
5949   }
5950 #endif
5951
5952   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
5953     if (!*(dirend+2)) dirend +=2;
5954     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
5955     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
5956   }
5957
5958   cp1 = rslt;
5959   cp2 = path;
5960   lastdot = strrchr(cp2,'.');
5961   if (*cp2 == '/') {
5962     char trndev[NAM$C_MAXRSS+1];
5963     int islnm, rooted;
5964     STRLEN trnend;
5965
5966     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
5967     if (!*(cp2+1)) {
5968       if (decc_disable_posix_root) {
5969         strcpy(rslt,"sys$disk:[000000]");
5970       }
5971       else {
5972         strcpy(rslt,"sys$posix_root:[000000]");
5973       }
5974       return rslt;
5975     }
5976     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
5977     *cp1 = '\0';
5978     islnm =  my_trnlnm(rslt,trndev,0);
5979
5980      /* DECC special handling */
5981     if (!islnm) {
5982       if (strcmp(rslt,"bin") == 0) {
5983         strcpy(rslt,"sys$system");
5984         cp1 = rslt + 10;
5985         *cp1 = 0;
5986         islnm =  my_trnlnm(rslt,trndev,0);
5987       }
5988       else if (strcmp(rslt,"tmp") == 0) {
5989         strcpy(rslt,"sys$scratch");
5990         cp1 = rslt + 11;
5991         *cp1 = 0;
5992         islnm =  my_trnlnm(rslt,trndev,0);
5993       }
5994       else if (!decc_disable_posix_root) {
5995         strcpy(rslt, "sys$posix_root");
5996         cp1 = rslt + 13;
5997         *cp1 = 0;
5998         cp2 = path;
5999         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
6000         islnm =  my_trnlnm(rslt,trndev,0);
6001       }
6002       else if (strcmp(rslt,"dev") == 0) {
6003         if (strncmp(cp2,"/null", 5) == 0) {
6004           if ((cp2[5] == 0) || (cp2[5] == '/')) {
6005             strcpy(rslt,"NLA0");
6006             cp1 = rslt + 4;
6007             *cp1 = 0;
6008             cp2 = cp2 + 5;
6009             islnm =  my_trnlnm(rslt,trndev,0);
6010           }
6011         }
6012       }
6013     }
6014
6015     trnend = islnm ? strlen(trndev) - 1 : 0;
6016     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6017     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6018     /* If the first element of the path is a logical name, determine
6019      * whether it has to be translated so we can add more directories. */
6020     if (!islnm || rooted) {
6021       *(cp1++) = ':';
6022       *(cp1++) = '[';
6023       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6024       else cp2++;
6025     }
6026     else {
6027       if (cp2 != dirend) {
6028         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
6029         strcpy(rslt,trndev);
6030         cp1 = rslt + trnend;
6031         if (*cp2 != 0) {
6032           *(cp1++) = '.';
6033           cp2++;
6034         }
6035       }
6036       else {
6037         if (decc_disable_posix_root) {
6038           *(cp1++) = ':';
6039           hasdir = 0;
6040         }
6041       }
6042     }
6043   }
6044   else {
6045     *(cp1++) = '[';
6046     if (*cp2 == '.') {
6047       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6048         cp2 += 2;         /* skip over "./" - it's redundant */
6049         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
6050       }
6051       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6052         *(cp1++) = '-';                                 /* "../" --> "-" */
6053         cp2 += 3;
6054       }
6055       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6056                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6057         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6058         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6059         cp2 += 4;
6060       }
6061       else if ((cp2 != lastdot) || (lastdot < dirend)) {
6062         /* Escape the extra dots in EFS file specifications */
6063         *(cp1++) = '^';
6064       }
6065       if (cp2 > dirend) cp2 = dirend;
6066     }
6067     else *(cp1++) = '.';
6068   }
6069   for (; cp2 < dirend; cp2++) {
6070     if (*cp2 == '/') {
6071       if (*(cp2-1) == '/') continue;
6072       if (*(cp1-1) != '.') *(cp1++) = '.';
6073       infront = 0;
6074     }
6075     else if (!infront && *cp2 == '.') {
6076       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6077       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
6078       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6079         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6080         else if (*(cp1-2) == '[') *(cp1-1) = '-';
6081         else {  /* back up over previous directory name */
6082           cp1--;
6083           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6084           if (*(cp1-1) == '[') {
6085             memcpy(cp1,"000000.",7);
6086             cp1 += 7;
6087           }
6088         }
6089         cp2 += 2;
6090         if (cp2 == dirend) break;
6091       }
6092       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6093                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6094         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6095         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6096         if (!*(cp2+3)) {
6097           *(cp1++) = '.';  /* Simulate trailing '/' */
6098           cp2 += 2;  /* for loop will incr this to == dirend */
6099         }
6100         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
6101       }
6102       else {
6103         if (decc_efs_charset == 0)
6104           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
6105         else {
6106           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
6107           *(cp1++) = '.';
6108         }
6109       }
6110     }
6111     else {
6112       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
6113       if (*cp2 == '.') {
6114         if (decc_efs_charset == 0)
6115           *(cp1++) = '_';
6116         else {
6117           *(cp1++) = '^';
6118           *(cp1++) = '.';
6119         }
6120       }
6121       else                  *(cp1++) =  *cp2;
6122       infront = 1;
6123     }
6124   }
6125   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6126   if (hasdir) *(cp1++) = ']';
6127   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
6128   /* fixme for ODS5 */
6129   no_type_seen = 0;
6130   if (cp2 > lastdot)
6131     no_type_seen = 1;
6132   while (*cp2) {
6133     switch(*cp2) {
6134     case '?':
6135         *(cp1++) = '%';
6136         cp2++;
6137     case ' ':
6138         *(cp1)++ = '^';
6139         *(cp1)++ = '_';
6140         cp2++;
6141         break;
6142     case '.':
6143         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6144             decc_readdir_dropdotnotype) {
6145           *(cp1)++ = '^';
6146           *(cp1)++ = '.';
6147           cp2++;
6148
6149           /* trailing dot ==> '^..' on VMS */
6150           if (*cp2 == '\0') {
6151             *(cp1++) = '.';
6152             no_type_seen = 0;
6153           }
6154         }
6155         else {
6156           *(cp1++) = *(cp2++);
6157           no_type_seen = 0;
6158         }
6159         break;
6160     case '\"':
6161     case '~':
6162     case '`':
6163     case '!':
6164     case '#':
6165     case '%':
6166     case '^':
6167     case '&':
6168     case '(':
6169     case ')':
6170     case '=':
6171     case '+':
6172     case '\'':
6173     case '@':
6174     case '[':
6175     case ']':
6176     case '{':
6177     case '}':
6178     case ':':
6179     case '\\':
6180     case '|':
6181     case '<':
6182     case '>':
6183         *(cp1++) = '^';
6184         *(cp1++) = *(cp2++);
6185         break;
6186     case ';':
6187         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6188          * which is wrong.  UNIX notation should be ".dir. unless
6189          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6190          * changing this behavior could break more things at this time.
6191          * efs character set effectively does not allow "." to be a version
6192          * delimiter as a further complication about changing this.
6193          */
6194         if (decc_filename_unix_report != 0) {
6195           *(cp1++) = '^';
6196         }
6197         *(cp1++) = *(cp2++);
6198         break;
6199     default:
6200         *(cp1++) = *(cp2++);
6201     }
6202   }
6203   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6204   char *lcp1;
6205     lcp1 = cp1;
6206     lcp1--;
6207      /* Fix me for "^]", but that requires making sure that you do
6208       * not back up past the start of the filename
6209       */
6210     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6211       *cp1++ = '.';
6212   }
6213   *cp1 = '\0';
6214
6215   return rslt;
6216
6217 }  /* end of do_tovmsspec() */
6218 /*}}}*/
6219 /* External entry points */
6220 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6221 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6222
6223 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6224 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6225   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
6226   int vmslen;
6227   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
6228
6229   if (path == NULL) return NULL;
6230   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
6231   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
6232   if (buf) return buf;
6233   else if (ts) {
6234     vmslen = strlen(vmsified);
6235     Newx(cp,vmslen+1,char);
6236     memcpy(cp,vmsified,vmslen);
6237     cp[vmslen] = '\0';
6238     return cp;
6239   }
6240   else {
6241     strcpy(__tovmspath_retbuf,vmsified);
6242     return __tovmspath_retbuf;
6243   }
6244
6245 }  /* end of do_tovmspath() */
6246 /*}}}*/
6247 /* External entry points */
6248 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6249 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6250
6251
6252 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6253 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6254   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
6255   int unixlen;
6256   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
6257
6258   if (path == NULL) return NULL;
6259   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
6260   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
6261   if (buf) return buf;
6262   else if (ts) {
6263     unixlen = strlen(unixified);
6264     Newx(cp,unixlen+1,char);
6265     memcpy(cp,unixified,unixlen);
6266     cp[unixlen] = '\0';
6267     return cp;
6268   }
6269   else {
6270     strcpy(__tounixpath_retbuf,unixified);
6271     return __tounixpath_retbuf;
6272   }
6273
6274 }  /* end of do_tounixpath() */
6275 /*}}}*/
6276 /* External entry points */
6277 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6278 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6279
6280 /*
6281  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
6282  *
6283  *****************************************************************************
6284  *                                                                           *
6285  *  Copyright (C) 1989-1994 by                                               *
6286  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
6287  *                                                                           *
6288  *  Permission is hereby  granted for the reproduction of this software,     *
6289  *  on condition that this copyright notice is included in the reproduction, *
6290  *  and that such reproduction is not for purposes of profit or material     *
6291  *  gain.                                                                    *
6292  *                                                                           *
6293  *  27-Aug-1994 Modified for inclusion in perl5                              *
6294  *              by Charles Bailey  bailey@newman.upenn.edu                   *
6295  *****************************************************************************
6296  */
6297
6298 /*
6299  * getredirection() is intended to aid in porting C programs
6300  * to VMS (Vax-11 C).  The native VMS environment does not support
6301  * '>' and '<' I/O redirection, or command line wild card expansion,
6302  * or a command line pipe mechanism using the '|' AND background
6303  * command execution '&'.  All of these capabilities are provided to any
6304  * C program which calls this procedure as the first thing in the
6305  * main program.
6306  * The piping mechanism will probably work with almost any 'filter' type
6307  * of program.  With suitable modification, it may useful for other
6308  * portability problems as well.
6309  *
6310  * Author:  Mark Pizzolato      mark@infocomm.com
6311  */
6312 struct list_item
6313     {
6314     struct list_item *next;
6315     char *value;
6316     };
6317
6318 static void add_item(struct list_item **head,
6319                      struct list_item **tail,
6320                      char *value,
6321                      int *count);
6322
6323 static void mp_expand_wild_cards(pTHX_ char *item,
6324                                 struct list_item **head,
6325                                 struct list_item **tail,
6326                                 int *count);
6327
6328 static int background_process(pTHX_ int argc, char **argv);
6329
6330 static void pipe_and_fork(pTHX_ char **cmargv);
6331
6332 /*{{{ void getredirection(int *ac, char ***av)*/
6333 static void
6334 mp_getredirection(pTHX_ int *ac, char ***av)
6335 /*
6336  * Process vms redirection arg's.  Exit if any error is seen.
6337  * If getredirection() processes an argument, it is erased
6338  * from the vector.  getredirection() returns a new argc and argv value.
6339  * In the event that a background command is requested (by a trailing "&"),
6340  * this routine creates a background subprocess, and simply exits the program.
6341  *
6342  * Warning: do not try to simplify the code for vms.  The code
6343  * presupposes that getredirection() is called before any data is
6344  * read from stdin or written to stdout.
6345  *
6346  * Normal usage is as follows:
6347  *
6348  *      main(argc, argv)
6349  *      int             argc;
6350  *      char            *argv[];
6351  *      {
6352  *              getredirection(&argc, &argv);
6353  *      }
6354  */
6355 {
6356     int                 argc = *ac;     /* Argument Count         */
6357     char                **argv = *av;   /* Argument Vector        */
6358     char                *ap;            /* Argument pointer       */
6359     int                 j;              /* argv[] index           */
6360     int                 item_count = 0; /* Count of Items in List */
6361     struct list_item    *list_head = 0; /* First Item in List       */
6362     struct list_item    *list_tail;     /* Last Item in List        */
6363     char                *in = NULL;     /* Input File Name          */
6364     char                *out = NULL;    /* Output File Name         */
6365     char                *outmode = "w"; /* Mode to Open Output File */
6366     char                *err = NULL;    /* Error File Name          */
6367     char                *errmode = "w"; /* Mode to Open Error File  */
6368     int                 cmargc = 0;     /* Piped Command Arg Count  */
6369     char                **cmargv = NULL;/* Piped Command Arg Vector */
6370
6371     /*
6372      * First handle the case where the last thing on the line ends with
6373      * a '&'.  This indicates the desire for the command to be run in a
6374      * subprocess, so we satisfy that desire.
6375      */
6376     ap = argv[argc-1];
6377     if (0 == strcmp("&", ap))
6378        exit(background_process(aTHX_ --argc, argv));
6379     if (*ap && '&' == ap[strlen(ap)-1])
6380         {
6381         ap[strlen(ap)-1] = '\0';
6382        exit(background_process(aTHX_ argc, argv));
6383         }
6384     /*
6385      * Now we handle the general redirection cases that involve '>', '>>',
6386      * '<', and pipes '|'.
6387      */
6388     for (j = 0; j < argc; ++j)
6389         {
6390         if (0 == strcmp("<", argv[j]))
6391             {
6392             if (j+1 >= argc)
6393                 {
6394                 fprintf(stderr,"No input file after < on command line");
6395                 exit(LIB$_WRONUMARG);
6396                 }
6397             in = argv[++j];
6398             continue;
6399             }
6400         if ('<' == *(ap = argv[j]))
6401             {
6402             in = 1 + ap;
6403             continue;
6404             }
6405         if (0 == strcmp(">", ap))
6406             {
6407             if (j+1 >= argc)
6408                 {
6409                 fprintf(stderr,"No output file after > on command line");
6410                 exit(LIB$_WRONUMARG);
6411                 }
6412             out = argv[++j];
6413             continue;
6414             }
6415         if ('>' == *ap)
6416             {
6417             if ('>' == ap[1])
6418                 {
6419                 outmode = "a";
6420                 if ('\0' == ap[2])
6421                     out = argv[++j];
6422                 else
6423                     out = 2 + ap;
6424                 }
6425             else
6426                 out = 1 + ap;
6427             if (j >= argc)
6428                 {
6429                 fprintf(stderr,"No output file after > or >> on command line");
6430                 exit(LIB$_WRONUMARG);
6431                 }
6432             continue;
6433             }
6434         if (('2' == *ap) && ('>' == ap[1]))
6435             {
6436             if ('>' == ap[2])
6437                 {
6438                 errmode = "a";
6439                 if ('\0' == ap[3])
6440                     err = argv[++j];
6441                 else
6442                     err = 3 + ap;
6443                 }
6444             else
6445                 if ('\0' == ap[2])
6446                     err = argv[++j];
6447                 else
6448                     err = 2 + ap;
6449             if (j >= argc)
6450                 {
6451                 fprintf(stderr,"No output file after 2> or 2>> on command line");
6452                 exit(LIB$_WRONUMARG);
6453                 }
6454             continue;
6455             }
6456         if (0 == strcmp("|", argv[j]))
6457             {
6458             if (j+1 >= argc)
6459                 {
6460                 fprintf(stderr,"No command into which to pipe on command line");
6461                 exit(LIB$_WRONUMARG);
6462                 }
6463             cmargc = argc-(j+1);
6464             cmargv = &argv[j+1];
6465             argc = j;
6466             continue;
6467             }
6468         if ('|' == *(ap = argv[j]))
6469             {
6470             ++argv[j];
6471             cmargc = argc-j;
6472             cmargv = &argv[j];
6473             argc = j;
6474             continue;
6475             }
6476         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6477         }
6478     /*
6479      * Allocate and fill in the new argument vector, Some Unix's terminate
6480      * the list with an extra null pointer.
6481      */
6482     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
6483     *av = argv;
6484     for (j = 0; j < item_count; ++j, list_head = list_head->next)
6485         argv[j] = list_head->value;
6486     *ac = item_count;
6487     if (cmargv != NULL)
6488         {
6489         if (out != NULL)
6490             {
6491             fprintf(stderr,"'|' and '>' may not both be specified on command line");
6492             exit(LIB$_INVARGORD);
6493             }
6494         pipe_and_fork(aTHX_ cmargv);
6495         }
6496
6497     /* Check for input from a pipe (mailbox) */
6498
6499     if (in == NULL && 1 == isapipe(0))
6500         {
6501         char mbxname[L_tmpnam];
6502         long int bufsize;
6503         long int dvi_item = DVI$_DEVBUFSIZ;
6504         $DESCRIPTOR(mbxnam, "");
6505         $DESCRIPTOR(mbxdevnam, "");
6506
6507         /* Input from a pipe, reopen it in binary mode to disable       */
6508         /* carriage control processing.                                 */
6509
6510         fgetname(stdin, mbxname);
6511         mbxnam.dsc$a_pointer = mbxname;
6512         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6513         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6514         mbxdevnam.dsc$a_pointer = mbxname;
6515         mbxdevnam.dsc$w_length = sizeof(mbxname);
6516         dvi_item = DVI$_DEVNAM;
6517         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6518         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
6519         set_errno(0);
6520         set_vaxc_errno(1);
6521         freopen(mbxname, "rb", stdin);
6522         if (errno != 0)
6523             {
6524             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
6525             exit(vaxc$errno);
6526             }
6527         }
6528     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6529         {
6530         fprintf(stderr,"Can't open input file %s as stdin",in);
6531         exit(vaxc$errno);
6532         }
6533     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
6534         {
6535         fprintf(stderr,"Can't open output file %s as stdout",out);
6536         exit(vaxc$errno);
6537         }
6538         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
6539
6540     if (err != NULL) {
6541         if (strcmp(err,"&1") == 0) {
6542             dup2(fileno(stdout), fileno(stderr));
6543             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
6544         } else {
6545         FILE *tmperr;
6546         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
6547             {
6548             fprintf(stderr,"Can't open error file %s as stderr",err);
6549             exit(vaxc$errno);
6550             }
6551             fclose(tmperr);
6552            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
6553                 {
6554                 exit(vaxc$errno);
6555                 }
6556             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
6557         }
6558         }
6559 #ifdef ARGPROC_DEBUG
6560     PerlIO_printf(Perl_debug_log, "Arglist:\n");
6561     for (j = 0; j < *ac;  ++j)
6562         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
6563 #endif
6564    /* Clear errors we may have hit expanding wildcards, so they don't
6565       show up in Perl's $! later */
6566    set_errno(0); set_vaxc_errno(1);
6567 }  /* end of getredirection() */
6568 /*}}}*/
6569
6570 static void add_item(struct list_item **head,
6571                      struct list_item **tail,
6572                      char *value,
6573                      int *count)
6574 {
6575     if (*head == 0)
6576         {
6577         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6578         *tail = *head;
6579         }
6580     else {
6581         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6582         *tail = (*tail)->next;
6583         }
6584     (*tail)->value = value;
6585     ++(*count);
6586 }
6587
6588 static void mp_expand_wild_cards(pTHX_ char *item,
6589                               struct list_item **head,
6590                               struct list_item **tail,
6591                               int *count)
6592 {
6593 int expcount = 0;
6594 unsigned long int context = 0;
6595 int isunix = 0;
6596 int item_len = 0;
6597 char *had_version;
6598 char *had_device;
6599 int had_directory;
6600 char *devdir,*cp;
6601 char vmsspec[NAM$C_MAXRSS+1];
6602 $DESCRIPTOR(filespec, "");
6603 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
6604 $DESCRIPTOR(resultspec, "");
6605 unsigned long int zero = 0, sts;
6606
6607     for (cp = item; *cp; cp++) {
6608         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
6609         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
6610     }
6611     if (!*cp || isspace(*cp))
6612         {
6613         add_item(head, tail, item, count);
6614         return;
6615         }
6616     else
6617         {
6618      /* "double quoted" wild card expressions pass as is */
6619      /* From DCL that means using e.g.:                  */
6620      /* perl program """perl.*"""                        */
6621      item_len = strlen(item);
6622      if ( '"' == *item && '"' == item[item_len-1] )
6623        {
6624        item++;
6625        item[item_len-2] = '\0';
6626        add_item(head, tail, item, count);
6627        return;
6628        }
6629      }
6630     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
6631     resultspec.dsc$b_class = DSC$K_CLASS_D;
6632     resultspec.dsc$a_pointer = NULL;
6633     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
6634       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
6635     if (!isunix || !filespec.dsc$a_pointer)
6636       filespec.dsc$a_pointer = item;
6637     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
6638     /*
6639      * Only return version specs, if the caller specified a version
6640      */
6641     had_version = strchr(item, ';');
6642     /*
6643      * Only return device and directory specs, if the caller specifed either.
6644      */
6645     had_device = strchr(item, ':');
6646     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
6647
6648     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
6649                                   &defaultspec, 0, 0, &zero))))
6650         {
6651         char *string;
6652         char *c;
6653
6654         Newx(string,resultspec.dsc$w_length+1,char);
6655         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
6656         string[resultspec.dsc$w_length] = '\0';
6657         if (NULL == had_version)
6658             *(strrchr(string, ';')) = '\0';
6659         if ((!had_directory) && (had_device == NULL))
6660             {
6661             if (NULL == (devdir = strrchr(string, ']')))
6662                 devdir = strrchr(string, '>');
6663             strcpy(string, devdir + 1);
6664             }
6665         /*
6666          * Be consistent with what the C RTL has already done to the rest of
6667          * the argv items and lowercase all of these names.
6668          */
6669         if (!decc_efs_case_preserve) {
6670             for (c = string; *c; ++c)
6671             if (isupper(*c))
6672                 *c = tolower(*c);
6673         }
6674         if (isunix) trim_unixpath(string,item,1);
6675         add_item(head, tail, string, count);
6676         ++expcount;
6677         }
6678     if (sts != RMS$_NMF)
6679         {
6680         set_vaxc_errno(sts);
6681         switch (sts)
6682             {
6683             case RMS$_FNF: case RMS$_DNF:
6684                 set_errno(ENOENT); break;
6685             case RMS$_DIR:
6686                 set_errno(ENOTDIR); break;
6687             case RMS$_DEV:
6688                 set_errno(ENODEV); break;
6689             case RMS$_FNM: case RMS$_SYN:
6690                 set_errno(EINVAL); break;
6691             case RMS$_PRV:
6692                 set_errno(EACCES); break;
6693             default:
6694                 _ckvmssts_noperl(sts);
6695             }
6696         }
6697     if (expcount == 0)
6698         add_item(head, tail, item, count);
6699     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
6700     _ckvmssts_noperl(lib$find_file_end(&context));
6701 }
6702
6703 static int child_st[2];/* Event Flag set when child process completes   */
6704
6705 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
6706
6707 static unsigned long int exit_handler(int *status)
6708 {
6709 short iosb[4];
6710
6711     if (0 == child_st[0])
6712         {
6713 #ifdef ARGPROC_DEBUG
6714         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
6715 #endif
6716         fflush(stdout);     /* Have to flush pipe for binary data to    */
6717                             /* terminate properly -- <tp@mccall.com>    */
6718         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
6719         sys$dassgn(child_chan);
6720         fclose(stdout);
6721         sys$synch(0, child_st);
6722         }
6723     return(1);
6724 }
6725
6726 static void sig_child(int chan)
6727 {
6728 #ifdef ARGPROC_DEBUG
6729     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
6730 #endif
6731     if (child_st[0] == 0)
6732         child_st[0] = 1;
6733 }
6734
6735 static struct exit_control_block exit_block =
6736     {
6737     0,
6738     exit_handler,
6739     1,
6740     &exit_block.exit_status,
6741     0
6742     };
6743
6744 static void
6745 pipe_and_fork(pTHX_ char **cmargv)
6746 {
6747     PerlIO *fp;
6748     struct dsc$descriptor_s *vmscmd;
6749     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
6750     int sts, j, l, ismcr, quote, tquote = 0;
6751
6752     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
6753     vms_execfree(vmscmd);
6754
6755     j = l = 0;
6756     p = subcmd;
6757     q = cmargv[0];
6758     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
6759               && toupper(*(q+2)) == 'R' && !*(q+3);
6760
6761     while (q && l < MAX_DCL_LINE_LENGTH) {
6762         if (!*q) {
6763             if (j > 0 && quote) {
6764                 *p++ = '"';
6765                 l++;
6766             }
6767             q = cmargv[++j];
6768             if (q) {
6769                 if (ismcr && j > 1) quote = 1;
6770                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
6771                 *p++ = ' ';
6772                 l++;
6773                 if (quote || tquote) {
6774                     *p++ = '"';
6775                     l++;
6776                 }
6777         }
6778         } else {
6779             if ((quote||tquote) && *q == '"') {
6780                 *p++ = '"';
6781                 l++;
6782         }
6783             *p++ = *q++;
6784             l++;
6785         }
6786     }
6787     *p = '\0';
6788
6789     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
6790     if (fp == Nullfp) {
6791         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
6792         }
6793 }
6794
6795 static int background_process(pTHX_ int argc, char **argv)
6796 {
6797 char command[2048] = "$";
6798 $DESCRIPTOR(value, "");
6799 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
6800 static $DESCRIPTOR(null, "NLA0:");
6801 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
6802 char pidstring[80];
6803 $DESCRIPTOR(pidstr, "");
6804 int pid;
6805 unsigned long int flags = 17, one = 1, retsts;
6806
6807     strcat(command, argv[0]);
6808     while (--argc)
6809         {
6810         strcat(command, " \"");
6811         strcat(command, *(++argv));
6812         strcat(command, "\"");
6813         }
6814     value.dsc$a_pointer = command;
6815     value.dsc$w_length = strlen(value.dsc$a_pointer);
6816     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
6817     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
6818     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
6819         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
6820     }
6821     else {
6822         _ckvmssts_noperl(retsts);
6823     }
6824 #ifdef ARGPROC_DEBUG
6825     PerlIO_printf(Perl_debug_log, "%s\n", command);
6826 #endif
6827     sprintf(pidstring, "%08X", pid);
6828     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
6829     pidstr.dsc$a_pointer = pidstring;
6830     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
6831     lib$set_symbol(&pidsymbol, &pidstr);
6832     return(SS$_NORMAL);
6833 }
6834 /*}}}*/
6835 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
6836
6837
6838 /* OS-specific initialization at image activation (not thread startup) */
6839 /* Older VAXC header files lack these constants */
6840 #ifndef JPI$_RIGHTS_SIZE
6841 #  define JPI$_RIGHTS_SIZE 817
6842 #endif
6843 #ifndef KGB$M_SUBSYSTEM
6844 #  define KGB$M_SUBSYSTEM 0x8
6845 #endif
6846
6847 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
6848
6849 /*{{{void vms_image_init(int *, char ***)*/
6850 void
6851 vms_image_init(int *argcp, char ***argvp)
6852 {
6853   char eqv[LNM$C_NAMLENGTH+1] = "";
6854   unsigned int len, tabct = 8, tabidx = 0;
6855   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
6856   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
6857   unsigned short int dummy, rlen;
6858   struct dsc$descriptor_s **tabvec;
6859 #if defined(PERL_IMPLICIT_CONTEXT)
6860   pTHX = NULL;
6861 #endif
6862   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
6863                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
6864                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
6865                                  {          0,                0,    0,      0} };
6866
6867 #ifdef KILL_BY_SIGPRC
6868     Perl_csighandler_init();
6869 #endif
6870
6871   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
6872   _ckvmssts_noperl(iosb[0]);
6873   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
6874     if (iprv[i]) {           /* Running image installed with privs? */
6875       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
6876       will_taint = TRUE;
6877       break;
6878     }
6879   }
6880   /* Rights identifiers might trigger tainting as well. */
6881   if (!will_taint && (rlen || rsz)) {
6882     while (rlen < rsz) {
6883       /* We didn't get all the identifiers on the first pass.  Allocate a
6884        * buffer much larger than $GETJPI wants (rsz is size in bytes that
6885        * were needed to hold all identifiers at time of last call; we'll
6886        * allocate that many unsigned long ints), and go back and get 'em.
6887        * If it gave us less than it wanted to despite ample buffer space,
6888        * something's broken.  Is your system missing a system identifier?
6889        */
6890       if (rsz <= jpilist[1].buflen) {
6891          /* Perl_croak accvios when used this early in startup. */
6892          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
6893                          rsz, (unsigned long) jpilist[1].buflen,
6894                          "Check your rights database for corruption.\n");
6895          exit(SS$_ABORT);
6896       }
6897       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
6898       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
6899       jpilist[1].buflen = rsz * sizeof(unsigned long int);
6900       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
6901       _ckvmssts_noperl(iosb[0]);
6902     }
6903     mask = jpilist[1].bufadr;
6904     /* Check attribute flags for each identifier (2nd longword); protected
6905      * subsystem identifiers trigger tainting.
6906      */
6907     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
6908       if (mask[i] & KGB$M_SUBSYSTEM) {
6909         will_taint = TRUE;
6910         break;
6911       }
6912     }
6913     if (mask != rlst) Safefree(mask);
6914   }
6915
6916   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
6917    * logical, some versions of the CRTL will add a phanthom /000000/
6918    * directory.  This needs to be removed.
6919    */
6920   if (decc_filename_unix_report) {
6921   char * zeros;
6922   int ulen;
6923     ulen = strlen(argvp[0][0]);
6924     if (ulen > 7) {
6925       zeros = strstr(argvp[0][0], "/000000/");
6926       if (zeros != NULL) {
6927         int mlen;
6928         mlen = ulen - (zeros - argvp[0][0]) - 7;
6929         memmove(zeros, &zeros[7], mlen);
6930         ulen = ulen - 7;
6931         argvp[0][0][ulen] = '\0';
6932       }
6933     }
6934     /* It also may have a trailing dot that needs to be removed otherwise
6935      * it will be converted to VMS mode incorrectly.
6936      */
6937     ulen--;
6938     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
6939       argvp[0][0][ulen] = '\0';
6940   }
6941
6942   /* We need to use this hack to tell Perl it should run with tainting,
6943    * since its tainting flag may be part of the PL_curinterp struct, which
6944    * hasn't been allocated when vms_image_init() is called.
6945    */
6946   if (will_taint) {
6947     char **newargv, **oldargv;
6948     oldargv = *argvp;
6949     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
6950     newargv[0] = oldargv[0];
6951     newargv[1] = (char *) PerlMem_malloc(3 * sizeof(char));
6952     strcpy(newargv[1], "-T");
6953     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
6954     (*argcp)++;
6955     newargv[*argcp] = NULL;
6956     /* We orphan the old argv, since we don't know where it's come from,
6957      * so we don't know how to free it.
6958      */
6959     *argvp = newargv;
6960   }
6961   else {  /* Did user explicitly request tainting? */
6962     int i;
6963     char *cp, **av = *argvp;
6964     for (i = 1; i < *argcp; i++) {
6965       if (*av[i] != '-') break;
6966       for (cp = av[i]+1; *cp; cp++) {
6967         if (*cp == 'T') { will_taint = 1; break; }
6968         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
6969                   strchr("DFIiMmx",*cp)) break;
6970       }
6971       if (will_taint) break;
6972     }
6973   }
6974
6975   for (tabidx = 0;
6976        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
6977        tabidx++) {
6978     if (!tabidx) tabvec = (struct dsc$descriptor_s **) PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
6979     else if (tabidx >= tabct) {
6980       tabct += 8;
6981       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
6982     }
6983     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
6984     tabvec[tabidx]->dsc$w_length  = 0;
6985     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
6986     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
6987     tabvec[tabidx]->dsc$a_pointer = NULL;
6988     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
6989   }
6990   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
6991
6992   getredirection(argcp,argvp);
6993 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
6994   {
6995 # include <reentrancy.h>
6996   decc$set_reentrancy(C$C_MULTITHREAD);
6997   }
6998 #endif
6999   return;
7000 }
7001 /*}}}*/
7002
7003
7004 /* trim_unixpath()
7005  * Trim Unix-style prefix off filespec, so it looks like what a shell
7006  * glob expansion would return (i.e. from specified prefix on, not
7007  * full path).  Note that returned filespec is Unix-style, regardless
7008  * of whether input filespec was VMS-style or Unix-style.
7009  *
7010  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7011  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
7012  * vector of options; at present, only bit 0 is used, and if set tells
7013  * trim unixpath to try the current default directory as a prefix when
7014  * presented with a possibly ambiguous ... wildcard.
7015  *
7016  * Returns !=0 on success, with trimmed filespec replacing contents of
7017  * fspec, and 0 on failure, with contents of fpsec unchanged.
7018  */
7019 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7020 int
7021 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7022 {
7023   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
7024        *template, *base, *end, *cp1, *cp2;
7025   register int tmplen, reslen = 0, dirs = 0;
7026
7027   if (!wildspec || !fspec) return 0;
7028   template = unixwild;
7029   if (strpbrk(wildspec,"]>:") != NULL) {
7030     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
7031   }
7032   else {
7033     strncpy(unixwild, wildspec, NAM$C_MAXRSS);
7034     unixwild[NAM$C_MAXRSS] = 0;
7035   }
7036   if (strpbrk(fspec,"]>:") != NULL) {
7037     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
7038     else base = unixified;
7039     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7040      * check to see that final result fits into (isn't longer than) fspec */
7041     reslen = strlen(fspec);
7042   }
7043   else base = fspec;
7044
7045   /* No prefix or absolute path on wildcard, so nothing to remove */
7046   if (!*template || *template == '/') {
7047     if (base == fspec) return 1;
7048     tmplen = strlen(unixified);
7049     if (tmplen > reslen) return 0;  /* not enough space */
7050     /* Copy unixified resultant, including trailing NUL */
7051     memmove(fspec,unixified,tmplen+1);
7052     return 1;
7053   }
7054
7055   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
7056   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7057     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7058     for (cp1 = end ;cp1 >= base; cp1--)
7059       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7060         { cp1++; break; }
7061     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7062     return 1;
7063   }
7064   else {
7065     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
7066     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7067     int ells = 1, totells, segdirs, match;
7068     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
7069                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7070
7071     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7072     totells = ells;
7073     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7074     if (ellipsis == template && opts & 1) {
7075       /* Template begins with an ellipsis.  Since we can't tell how many
7076        * directory names at the front of the resultant to keep for an
7077        * arbitrary starting point, we arbitrarily choose the current
7078        * default directory as a starting point.  If it's there as a prefix,
7079        * clip it off.  If not, fall through and act as if the leading
7080        * ellipsis weren't there (i.e. return shortest possible path that
7081        * could match template).
7082        */
7083       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
7084       if (!decc_efs_case_preserve) {
7085         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7086           if (_tolower(*cp1) != _tolower(*cp2)) break;
7087       }
7088       segdirs = dirs - totells;  /* Min # of dirs we must have left */
7089       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7090       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7091         memmove(fspec,cp2+1,end - cp2);
7092         return 1;
7093       }
7094     }
7095     /* First off, back up over constant elements at end of path */
7096     if (dirs) {
7097       for (front = end ; front >= base; front--)
7098          if (*front == '/' && !dirs--) { front++; break; }
7099     }
7100     if (!decc_efs_case_preserve) {
7101       for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
7102          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
7103     }
7104     if (cp1 != '\0') return 0;  /* Path too long. */
7105     lcend = cp2;
7106     *cp2 = '\0';  /* Pick up with memcpy later */
7107     lcfront = lcres + (front - base);
7108     /* Now skip over each ellipsis and try to match the path in front of it. */
7109     while (ells--) {
7110       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7111         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
7112             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
7113       if (cp1 < template) break; /* template started with an ellipsis */
7114       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7115         ellipsis = cp1; continue;
7116       }
7117       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7118       nextell = cp1;
7119       for (segdirs = 0, cp2 = tpl;
7120            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
7121            cp1++, cp2++) {
7122          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7123          else {
7124             if (!decc_efs_case_preserve) {
7125               *cp2 = _tolower(*cp1);  /* else lowercase for match */
7126             }
7127             else {
7128               *cp2 = *cp1;  /* else preserve case for match */
7129             }
7130          }
7131          if (*cp2 == '/') segdirs++;
7132       }
7133       if (cp1 != ellipsis - 1) return 0; /* Path too long */
7134       /* Back up at least as many dirs as in template before matching */
7135       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7136         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7137       for (match = 0; cp1 > lcres;) {
7138         resdsc.dsc$a_pointer = cp1;
7139         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7140           match++;
7141           if (match == 1) lcfront = cp1;
7142         }
7143         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7144       }
7145       if (!match) return 0;  /* Can't find prefix ??? */
7146       if (match > 1 && opts & 1) {
7147         /* This ... wildcard could cover more than one set of dirs (i.e.
7148          * a set of similar dir names is repeated).  If the template
7149          * contains more than 1 ..., upstream elements could resolve the
7150          * ambiguity, but it's not worth a full backtracking setup here.
7151          * As a quick heuristic, clip off the current default directory
7152          * if it's present to find the trimmed spec, else use the
7153          * shortest string that this ... could cover.
7154          */
7155         char def[NAM$C_MAXRSS+1], *st;
7156
7157         if (getcwd(def, sizeof def,0) == NULL) return 0;
7158         if (!decc_efs_case_preserve) {
7159           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7160             if (_tolower(*cp1) != _tolower(*cp2)) break;
7161         }
7162         segdirs = dirs - totells;  /* Min # of dirs we must have left */
7163         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7164         if (*cp1 == '\0' && *cp2 == '/') {
7165           memmove(fspec,cp2+1,end - cp2);
7166           return 1;
7167         }
7168         /* Nope -- stick with lcfront from above and keep going. */
7169       }
7170     }
7171     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7172     return 1;
7173     ellipsis = nextell;
7174   }
7175
7176 }  /* end of trim_unixpath() */
7177 /*}}}*/
7178
7179
7180 /*
7181  *  VMS readdir() routines.
7182  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7183  *
7184  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
7185  *  Minor modifications to original routines.
7186  */
7187
7188 /* readdir may have been redefined by reentr.h, so make sure we get
7189  * the local version for what we do here.
7190  */
7191 #ifdef readdir
7192 # undef readdir
7193 #endif
7194 #if !defined(PERL_IMPLICIT_CONTEXT)
7195 # define readdir Perl_readdir
7196 #else
7197 # define readdir(a) Perl_readdir(aTHX_ a)
7198 #endif
7199
7200     /* Number of elements in vms_versions array */
7201 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
7202
7203 /*
7204  *  Open a directory, return a handle for later use.
7205  */
7206 /*{{{ DIR *opendir(char*name) */
7207 MY_DIR *
7208 Perl_opendir(pTHX_ const char *name)
7209 {
7210     MY_DIR *dd;
7211     char dir[NAM$C_MAXRSS+1];
7212     Stat_t sb;
7213
7214     if (do_tovmspath(name,dir,0) == NULL) {
7215       return NULL;
7216     }
7217     /* Check access before stat; otherwise stat does not
7218      * accurately report whether it's a directory.
7219      */
7220     if (!cando_by_name(S_IRUSR,0,dir)) {
7221       /* cando_by_name has already set errno */
7222       return NULL;
7223     }
7224     if (flex_stat(dir,&sb) == -1) return NULL;
7225     if (!S_ISDIR(sb.st_mode)) {
7226       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
7227       return NULL;
7228     }
7229     /* Get memory for the handle, and the pattern. */
7230     Newx(dd,1,MY_DIR);
7231     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7232
7233     /* Fill in the fields; mainly playing with the descriptor. */
7234     sprintf(dd->pattern, "%s*.*",dir);
7235     dd->context = 0;
7236     dd->count = 0;
7237     dd->vms_wantversions = 0;
7238     dd->pat.dsc$a_pointer = dd->pattern;
7239     dd->pat.dsc$w_length = strlen(dd->pattern);
7240     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7241     dd->pat.dsc$b_class = DSC$K_CLASS_S;
7242 #if defined(USE_ITHREADS)
7243     Newx(dd->mutex,1,perl_mutex);
7244     MUTEX_INIT( (perl_mutex *) dd->mutex );
7245 #else
7246     dd->mutex = NULL;
7247 #endif
7248
7249     return dd;
7250 }  /* end of opendir() */
7251 /*}}}*/
7252
7253 /*
7254  *  Set the flag to indicate we want versions or not.
7255  */
7256 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7257 void
7258 vmsreaddirversions(MY_DIR *dd, int flag)
7259 {
7260     dd->vms_wantversions = flag;
7261 }
7262 /*}}}*/
7263
7264 /*
7265  *  Free up an opened directory.
7266  */
7267 /*{{{ void closedir(DIR *dd)*/
7268 void
7269 Perl_closedir(MY_DIR *dd)
7270 {
7271     int sts;
7272
7273     sts = lib$find_file_end(&dd->context);
7274     Safefree(dd->pattern);
7275 #if defined(USE_ITHREADS)
7276     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7277     Safefree(dd->mutex);
7278 #endif
7279     Safefree(dd);
7280 }
7281 /*}}}*/
7282
7283 /*
7284  *  Collect all the version numbers for the current file.
7285  */
7286 static void
7287 collectversions(pTHX_ MY_DIR *dd)
7288 {
7289     struct dsc$descriptor_s     pat;
7290     struct dsc$descriptor_s     res;
7291     struct my_dirent *e;
7292     char *p, *text, buff[sizeof dd->entry.d_name];
7293     int i;
7294     unsigned long context, tmpsts;
7295
7296     /* Convenient shorthand. */
7297     e = &dd->entry;
7298
7299     /* Add the version wildcard, ignoring the "*.*" put on before */
7300     i = strlen(dd->pattern);
7301     Newx(text,i + e->d_namlen + 3,char);
7302     strcpy(text, dd->pattern);
7303     sprintf(&text[i - 3], "%s;*", e->d_name);
7304
7305     /* Set up the pattern descriptor. */
7306     pat.dsc$a_pointer = text;
7307     pat.dsc$w_length = i + e->d_namlen - 1;
7308     pat.dsc$b_dtype = DSC$K_DTYPE_T;
7309     pat.dsc$b_class = DSC$K_CLASS_S;
7310
7311     /* Set up result descriptor. */
7312     res.dsc$a_pointer = buff;
7313     res.dsc$w_length = sizeof buff - 2;
7314     res.dsc$b_dtype = DSC$K_DTYPE_T;
7315     res.dsc$b_class = DSC$K_CLASS_S;
7316
7317     /* Read files, collecting versions. */
7318     for (context = 0, e->vms_verscount = 0;
7319          e->vms_verscount < VERSIZE(e);
7320          e->vms_verscount++) {
7321         tmpsts = lib$find_file(&pat, &res, &context);
7322         if (tmpsts == RMS$_NMF || context == 0) break;
7323         _ckvmssts(tmpsts);
7324         buff[sizeof buff - 1] = '\0';
7325         if ((p = strchr(buff, ';')))
7326             e->vms_versions[e->vms_verscount] = atoi(p + 1);
7327         else
7328             e->vms_versions[e->vms_verscount] = -1;
7329     }
7330
7331     _ckvmssts(lib$find_file_end(&context));
7332     Safefree(text);
7333
7334 }  /* end of collectversions() */
7335
7336 /*
7337  *  Read the next entry from the directory.
7338  */
7339 /*{{{ struct dirent *readdir(DIR *dd)*/
7340 struct my_dirent *
7341 Perl_readdir(pTHX_ MY_DIR *dd)
7342 {
7343     struct dsc$descriptor_s     res;
7344     char *p, buff[sizeof dd->entry.d_name];
7345     unsigned long int tmpsts;
7346
7347     /* Set up result descriptor, and get next file. */
7348     res.dsc$a_pointer = buff;
7349     res.dsc$w_length = sizeof buff - 2;
7350     res.dsc$b_dtype = DSC$K_DTYPE_T;
7351     res.dsc$b_class = DSC$K_CLASS_S;
7352     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
7353     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
7354     if (!(tmpsts & 1)) {
7355       set_vaxc_errno(tmpsts);
7356       switch (tmpsts) {
7357         case RMS$_PRV:
7358           set_errno(EACCES); break;
7359         case RMS$_DEV:
7360           set_errno(ENODEV); break;
7361         case RMS$_DIR:
7362           set_errno(ENOTDIR); break;
7363         case RMS$_FNF: case RMS$_DNF:
7364           set_errno(ENOENT); break;
7365         default:
7366           set_errno(EVMSERR);
7367       }
7368       return NULL;
7369     }
7370     dd->count++;
7371     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
7372     if (!decc_efs_case_preserve) {
7373       buff[sizeof buff - 1] = '\0';
7374       for (p = buff; *p; p++) *p = _tolower(*p);
7375       while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7376       *p = '\0';
7377     }
7378     else {
7379       /* we don't want to force to lowercase, just null terminate */
7380       buff[res.dsc$w_length] = '\0';
7381     }
7382     for (p = buff; *p; p++) *p = _tolower(*p);
7383     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
7384     *p = '\0';
7385
7386     /* Skip any directory component and just copy the name. */
7387     if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1);
7388     else strcpy(dd->entry.d_name, buff);
7389
7390     /* Clobber the version. */
7391     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
7392
7393     dd->entry.d_namlen = strlen(dd->entry.d_name);
7394     dd->entry.vms_verscount = 0;
7395     if (dd->vms_wantversions) collectversions(aTHX_ dd);
7396     return &dd->entry;
7397
7398 }  /* end of readdir() */
7399 /*}}}*/
7400
7401 /*
7402  *  Read the next entry from the directory -- thread-safe version.
7403  */
7404 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
7405 int
7406 Perl_readdir_r(pTHX_ MY_DIR *dd, struct my_dirent *entry, struct my_dirent **result)
7407 {
7408     int retval;
7409
7410     MUTEX_LOCK( (perl_mutex *) dd->mutex );
7411
7412     entry = readdir(dd);
7413     *result = entry;
7414     retval = ( *result == NULL ? errno : 0 );
7415
7416     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
7417
7418     return retval;
7419
7420 }  /* end of readdir_r() */
7421 /*}}}*/
7422
7423 /*
7424  *  Return something that can be used in a seekdir later.
7425  */
7426 /*{{{ long telldir(DIR *dd)*/
7427 long
7428 Perl_telldir(MY_DIR *dd)
7429 {
7430     return dd->count;
7431 }
7432 /*}}}*/
7433
7434 /*
7435  *  Return to a spot where we used to be.  Brute force.
7436  */
7437 /*{{{ void seekdir(DIR *dd,long count)*/
7438 void
7439 Perl_seekdir(pTHX_ MY_DIR *dd, long count)
7440 {
7441     int vms_wantversions;
7442
7443     /* If we haven't done anything yet... */
7444     if (dd->count == 0)
7445         return;
7446
7447     /* Remember some state, and clear it. */
7448     vms_wantversions = dd->vms_wantversions;
7449     dd->vms_wantversions = 0;
7450     _ckvmssts(lib$find_file_end(&dd->context));
7451     dd->context = 0;
7452
7453     /* The increment is in readdir(). */
7454     for (dd->count = 0; dd->count < count; )
7455         readdir(dd);
7456
7457     dd->vms_wantversions = vms_wantversions;
7458
7459 }  /* end of seekdir() */
7460 /*}}}*/
7461
7462 /* VMS subprocess management
7463  *
7464  * my_vfork() - just a vfork(), after setting a flag to record that
7465  * the current script is trying a Unix-style fork/exec.
7466  *
7467  * vms_do_aexec() and vms_do_exec() are called in response to the
7468  * perl 'exec' function.  If this follows a vfork call, then they
7469  * call out the regular perl routines in doio.c which do an
7470  * execvp (for those who really want to try this under VMS).
7471  * Otherwise, they do exactly what the perl docs say exec should
7472  * do - terminate the current script and invoke a new command
7473  * (See below for notes on command syntax.)
7474  *
7475  * do_aspawn() and do_spawn() implement the VMS side of the perl
7476  * 'system' function.
7477  *
7478  * Note on command arguments to perl 'exec' and 'system': When handled
7479  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
7480  * are concatenated to form a DCL command string.  If the first arg
7481  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
7482  * the command string is handed off to DCL directly.  Otherwise,
7483  * the first token of the command is taken as the filespec of an image
7484  * to run.  The filespec is expanded using a default type of '.EXE' and
7485  * the process defaults for device, directory, etc., and if found, the resultant
7486  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
7487  * the command string as parameters.  This is perhaps a bit complicated,
7488  * but I hope it will form a happy medium between what VMS folks expect
7489  * from lib$spawn and what Unix folks expect from exec.
7490  */
7491
7492 static int vfork_called;
7493
7494 /*{{{int my_vfork()*/
7495 int
7496 my_vfork()
7497 {
7498   vfork_called++;
7499   return vfork();
7500 }
7501 /*}}}*/
7502
7503
7504 static void
7505 vms_execfree(struct dsc$descriptor_s *vmscmd)
7506 {
7507   if (vmscmd) {
7508       if (vmscmd->dsc$a_pointer) {
7509           Safefree(vmscmd->dsc$a_pointer);
7510       }
7511       Safefree(vmscmd);
7512   }
7513 }
7514
7515 static char *
7516 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
7517 {
7518   char *junk, *tmps = Nullch;
7519   register size_t cmdlen = 0;
7520   size_t rlen;
7521   register SV **idx;
7522   STRLEN n_a;
7523
7524   idx = mark;
7525   if (really) {
7526     tmps = SvPV(really,rlen);
7527     if (*tmps) {
7528       cmdlen += rlen + 1;
7529       idx++;
7530     }
7531   }
7532
7533   for (idx++; idx <= sp; idx++) {
7534     if (*idx) {
7535       junk = SvPVx(*idx,rlen);
7536       cmdlen += rlen ? rlen + 1 : 0;
7537     }
7538   }
7539   Newx(PL_Cmd,cmdlen+1,char);
7540
7541   if (tmps && *tmps) {
7542     strcpy(PL_Cmd,tmps);
7543     mark++;
7544   }
7545   else *PL_Cmd = '\0';
7546   while (++mark <= sp) {
7547     if (*mark) {
7548       char *s = SvPVx(*mark,n_a);
7549       if (!*s) continue;
7550       if (*PL_Cmd) strcat(PL_Cmd," ");
7551       strcat(PL_Cmd,s);
7552     }
7553   }
7554   return PL_Cmd;
7555
7556 }  /* end of setup_argstr() */
7557
7558
7559 static unsigned long int
7560 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
7561                    struct dsc$descriptor_s **pvmscmd)
7562 {
7563   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
7564   char image_name[NAM$C_MAXRSS+1];
7565   char image_argv[NAM$C_MAXRSS+1];
7566   $DESCRIPTOR(defdsc,".EXE");
7567   $DESCRIPTOR(defdsc2,".");
7568   $DESCRIPTOR(resdsc,resspec);
7569   struct dsc$descriptor_s *vmscmd;
7570   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7571   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
7572   register char *s, *rest, *cp, *wordbreak;
7573   char * cmd;
7574   int cmdlen;
7575   register int isdcl;
7576
7577   Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
7578
7579   /* Make a copy for modification */
7580   cmdlen = strlen(incmd);
7581   Newx(cmd, cmdlen+1, char);
7582   strncpy(cmd, incmd, cmdlen);
7583   cmd[cmdlen] = 0;
7584   image_name[0] = 0;
7585   image_argv[0] = 0;
7586
7587   vmscmd->dsc$a_pointer = NULL;
7588   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
7589   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
7590   vmscmd->dsc$w_length = 0;
7591   if (pvmscmd) *pvmscmd = vmscmd;
7592
7593   if (suggest_quote) *suggest_quote = 0;
7594
7595   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
7596     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
7597     Safefree(cmd);
7598   }
7599
7600   s = cmd;
7601
7602   while (*s && isspace(*s)) s++;
7603
7604   if (*s == '@' || *s == '$') {
7605     vmsspec[0] = *s;  rest = s + 1;
7606     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
7607   }
7608   else { cp = vmsspec; rest = s; }
7609   if (*rest == '.' || *rest == '/') {
7610     char *cp2;
7611     for (cp2 = resspec;
7612          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
7613          rest++, cp2++) *cp2 = *rest;
7614     *cp2 = '\0';
7615     if (do_tovmsspec(resspec,cp,0)) {
7616       s = vmsspec;
7617       if (*rest) {
7618         for (cp2 = vmsspec + strlen(vmsspec);
7619              *rest && cp2 - vmsspec < sizeof vmsspec;
7620              rest++, cp2++) *cp2 = *rest;
7621         *cp2 = '\0';
7622       }
7623     }
7624   }
7625   /* Intuit whether verb (first word of cmd) is a DCL command:
7626    *   - if first nonspace char is '@', it's a DCL indirection
7627    * otherwise
7628    *   - if verb contains a filespec separator, it's not a DCL command
7629    *   - if it doesn't, caller tells us whether to default to a DCL
7630    *     command, or to a local image unless told it's DCL (by leading '$')
7631    */
7632   if (*s == '@') {
7633       isdcl = 1;
7634       if (suggest_quote) *suggest_quote = 1;
7635   } else {
7636     register char *filespec = strpbrk(s,":<[.;");
7637     rest = wordbreak = strpbrk(s," \"\t/");
7638     if (!wordbreak) wordbreak = s + strlen(s);
7639     if (*s == '$') check_img = 0;
7640     if (filespec && (filespec < wordbreak)) isdcl = 0;
7641     else isdcl = !check_img;
7642   }
7643
7644   if (!isdcl) {
7645     imgdsc.dsc$a_pointer = s;
7646     imgdsc.dsc$w_length = wordbreak - s;
7647     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7648     if (!(retsts&1)) {
7649         _ckvmssts(lib$find_file_end(&cxt));
7650         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7651       if (!(retsts & 1) && *s == '$') {
7652         _ckvmssts(lib$find_file_end(&cxt));
7653         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
7654         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7655         if (!(retsts&1)) {
7656           _ckvmssts(lib$find_file_end(&cxt));
7657           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7658         }
7659       }
7660     }
7661     _ckvmssts(lib$find_file_end(&cxt));
7662
7663     if (retsts & 1) {
7664       FILE *fp;
7665       s = resspec;
7666       while (*s && !isspace(*s)) s++;
7667       *s = '\0';
7668
7669       /* check that it's really not DCL with no file extension */
7670       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
7671       if (fp) {
7672         char b[256] = {0,0,0,0};
7673         read(fileno(fp), b, 256);
7674         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
7675         if (isdcl) {
7676           int shebang_len;
7677
7678           /* Check for script */
7679           shebang_len = 0;
7680           if ((b[0] == '#') && (b[1] == '!'))
7681              shebang_len = 2;
7682 #ifdef ALTERNATE_SHEBANG
7683           else {
7684             shebang_len = strlen(ALTERNATE_SHEBANG);
7685             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
7686               char * perlstr;
7687                 perlstr = strstr("perl",b);
7688                 if (perlstr == NULL)
7689                   shebang_len = 0;
7690             }
7691             else
7692               shebang_len = 0;
7693           }
7694 #endif
7695
7696           if (shebang_len > 0) {
7697           int i;
7698           int j;
7699           char tmpspec[NAM$C_MAXRSS + 1];
7700
7701             i = shebang_len;
7702              /* Image is following after white space */
7703             /*--------------------------------------*/
7704             while (isprint(b[i]) && isspace(b[i]))
7705                 i++;
7706
7707             j = 0;
7708             while (isprint(b[i]) && !isspace(b[i])) {
7709                 tmpspec[j++] = b[i++];
7710                 if (j >= NAM$C_MAXRSS)
7711                    break;
7712             }
7713             tmpspec[j] = '\0';
7714
7715              /* There may be some default parameters to the image */
7716             /*---------------------------------------------------*/
7717             j = 0;
7718             while (isprint(b[i])) {
7719                 image_argv[j++] = b[i++];
7720                 if (j >= NAM$C_MAXRSS)
7721                    break;
7722             }
7723             while ((j > 0) && !isprint(image_argv[j-1]))
7724                 j--;
7725             image_argv[j] = 0;
7726
7727             /* It will need to be converted to VMS format and validated */
7728             if (tmpspec[0] != '\0') {
7729               char * iname;
7730
7731                /* Try to find the exact program requested to be run */
7732               /*---------------------------------------------------*/
7733               iname = do_rmsexpand
7734                   (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
7735               if (iname != NULL) {
7736                 if (cando_by_name(S_IXUSR,0,image_name)) {
7737                   /* MCR prefix needed */
7738                   isdcl = 0;
7739                 }
7740                 else {
7741                    /* Try again with a null type */
7742                   /*----------------------------*/
7743                   iname = do_rmsexpand
7744                     (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
7745                   if (iname != NULL) {
7746                     if (cando_by_name(S_IXUSR,0,image_name)) {
7747                       /* MCR prefix needed */
7748                       isdcl = 0;
7749                     }
7750                   }
7751                 }
7752
7753                  /* Did we find the image to run the script? */
7754                 /*------------------------------------------*/
7755                 if (isdcl) {
7756                   char *tchr;
7757
7758                    /* Assume DCL or foreign command exists */
7759                   /*--------------------------------------*/
7760                   tchr = strrchr(tmpspec, '/');
7761                   if (tchr != NULL) {
7762                     tchr++;
7763                   }
7764                   else {
7765                     tchr = tmpspec;
7766                   }
7767                   strcpy(image_name, tchr);
7768                 }
7769               }
7770             }
7771           }
7772         }
7773         fclose(fp);
7774       }
7775       if (check_img && isdcl) return RMS$_FNF;
7776
7777       if (cando_by_name(S_IXUSR,0,resspec)) {
7778         Newx(vmscmd->dsc$a_pointer, MAX_DCL_LINE_LENGTH ,char);
7779         if (!isdcl) {
7780             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
7781             if (image_name[0] != 0) {
7782                 strcat(vmscmd->dsc$a_pointer, image_name);
7783                 strcat(vmscmd->dsc$a_pointer, " ");
7784             }
7785         } else if (image_name[0] != 0) {
7786             strcpy(vmscmd->dsc$a_pointer, image_name);
7787             strcat(vmscmd->dsc$a_pointer, " ");
7788         } else {
7789             strcpy(vmscmd->dsc$a_pointer,"@");
7790         }
7791         if (suggest_quote) *suggest_quote = 1;
7792
7793         /* If there is an image name, use original command */
7794         if (image_name[0] == 0)
7795             strcat(vmscmd->dsc$a_pointer,resspec);
7796         else {
7797             rest = cmd;
7798             while (*rest && isspace(*rest)) rest++;
7799         }
7800
7801         if (image_argv[0] != 0) {
7802           strcat(vmscmd->dsc$a_pointer,image_argv);
7803           strcat(vmscmd->dsc$a_pointer, " ");
7804         }
7805         if (rest) {
7806            int rest_len;
7807            int vmscmd_len;
7808
7809            rest_len = strlen(rest);
7810            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
7811            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
7812               strcat(vmscmd->dsc$a_pointer,rest);
7813            else
7814              retsts = CLI$_BUFOVF;
7815         }
7816         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
7817         Safefree(cmd);
7818         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
7819       }
7820       else retsts = RMS$_PRV;
7821     }
7822   }
7823   /* It's either a DCL command or we couldn't find a suitable image */
7824   vmscmd->dsc$w_length = strlen(cmd);
7825 /*  if (cmd == PL_Cmd) {
7826       vmscmd->dsc$a_pointer = PL_Cmd;
7827       if (suggest_quote) *suggest_quote = 1;
7828   }
7829   else  */
7830       vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
7831
7832   Safefree(cmd);
7833
7834   /* check if it's a symbol (for quoting purposes) */
7835   if (suggest_quote && !*suggest_quote) {
7836     int iss;
7837     char equiv[LNM$C_NAMLENGTH];
7838     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7839     eqvdsc.dsc$a_pointer = equiv;
7840
7841     iss = lib$get_symbol(vmscmd,&eqvdsc);
7842     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
7843   }
7844   if (!(retsts & 1)) {
7845     /* just hand off status values likely to be due to user error */
7846     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
7847         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
7848        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
7849     else { _ckvmssts(retsts); }
7850   }
7851
7852   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
7853
7854 }  /* end of setup_cmddsc() */
7855
7856
7857 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
7858 bool
7859 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
7860 {
7861   if (sp > mark) {
7862     if (vfork_called) {           /* this follows a vfork - act Unixish */
7863       vfork_called--;
7864       if (vfork_called < 0) {
7865         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
7866         vfork_called = 0;
7867       }
7868       else return do_aexec(really,mark,sp);
7869     }
7870                                            /* no vfork - act VMSish */
7871     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
7872
7873   }
7874
7875   return FALSE;
7876 }  /* end of vms_do_aexec() */
7877 /*}}}*/
7878
7879 /* {{{bool vms_do_exec(char *cmd) */
7880 bool
7881 Perl_vms_do_exec(pTHX_ const char *cmd)
7882 {
7883   struct dsc$descriptor_s *vmscmd;
7884
7885   if (vfork_called) {             /* this follows a vfork - act Unixish */
7886     vfork_called--;
7887     if (vfork_called < 0) {
7888       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
7889       vfork_called = 0;
7890     }
7891     else return do_exec(cmd);
7892   }
7893
7894   {                               /* no vfork - act VMSish */
7895     unsigned long int retsts;
7896
7897     TAINT_ENV();
7898     TAINT_PROPER("exec");
7899     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
7900       retsts = lib$do_command(vmscmd);
7901
7902     switch (retsts) {
7903       case RMS$_FNF: case RMS$_DNF:
7904         set_errno(ENOENT); break;
7905       case RMS$_DIR:
7906         set_errno(ENOTDIR); break;
7907       case RMS$_DEV:
7908         set_errno(ENODEV); break;
7909       case RMS$_PRV:
7910         set_errno(EACCES); break;
7911       case RMS$_SYN:
7912         set_errno(EINVAL); break;
7913       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
7914         set_errno(E2BIG); break;
7915       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
7916         _ckvmssts(retsts); /* fall through */
7917       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
7918         set_errno(EVMSERR);
7919     }
7920     set_vaxc_errno(retsts);
7921     if (ckWARN(WARN_EXEC)) {
7922       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
7923              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
7924     }
7925     vms_execfree(vmscmd);
7926   }
7927
7928   return FALSE;
7929
7930 }  /* end of vms_do_exec() */
7931 /*}}}*/
7932
7933 unsigned long int Perl_do_spawn(pTHX_ const char *);
7934
7935 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
7936 unsigned long int
7937 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
7938 {
7939   if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
7940
7941   return SS$_ABORT;
7942 }  /* end of do_aspawn() */
7943 /*}}}*/
7944
7945 /* {{{unsigned long int do_spawn(char *cmd) */
7946 unsigned long int
7947 Perl_do_spawn(pTHX_ const char *cmd)
7948 {
7949   unsigned long int sts, substs;
7950
7951   TAINT_ENV();
7952   TAINT_PROPER("spawn");
7953   if (!cmd || !*cmd) {
7954     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
7955     if (!(sts & 1)) {
7956       switch (sts) {
7957         case RMS$_FNF:  case RMS$_DNF:
7958           set_errno(ENOENT); break;
7959         case RMS$_DIR:
7960           set_errno(ENOTDIR); break;
7961         case RMS$_DEV:
7962           set_errno(ENODEV); break;
7963         case RMS$_PRV:
7964           set_errno(EACCES); break;
7965         case RMS$_SYN:
7966           set_errno(EINVAL); break;
7967         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
7968           set_errno(E2BIG); break;
7969         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
7970           _ckvmssts(sts); /* fall through */
7971         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
7972           set_errno(EVMSERR);
7973       }
7974       set_vaxc_errno(sts);
7975       if (ckWARN(WARN_EXEC)) {
7976         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
7977                     Strerror(errno));
7978       }
7979     }
7980     sts = substs;
7981   }
7982   else {
7983     PerlIO * fp;
7984     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
7985     if (fp != NULL)
7986       my_pclose(fp);
7987   }
7988   return sts;
7989 }  /* end of do_spawn() */
7990 /*}}}*/
7991
7992
7993 static unsigned int *sockflags, sockflagsize;
7994
7995 /*
7996  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
7997  * routines found in some versions of the CRTL can't deal with sockets.
7998  * We don't shim the other file open routines since a socket isn't
7999  * likely to be opened by a name.
8000  */
8001 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8002 FILE *my_fdopen(int fd, const char *mode)
8003 {
8004   FILE *fp = fdopen(fd, mode);
8005
8006   if (fp) {
8007     unsigned int fdoff = fd / sizeof(unsigned int);
8008     Stat_t sbuf; /* native stat; we don't need flex_stat */
8009     if (!sockflagsize || fdoff > sockflagsize) {
8010       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
8011       else           Newx  (sockflags,fdoff+2,unsigned int);
8012       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8013       sockflagsize = fdoff + 2;
8014     }
8015     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8016       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8017   }
8018   return fp;
8019
8020 }
8021 /*}}}*/
8022
8023
8024 /*
8025  * Clear the corresponding bit when the (possibly) socket stream is closed.
8026  * There still a small hole: we miss an implicit close which might occur
8027  * via freopen().  >> Todo
8028  */
8029 /*{{{ int my_fclose(FILE *fp)*/
8030 int my_fclose(FILE *fp) {
8031   if (fp) {
8032     unsigned int fd = fileno(fp);
8033     unsigned int fdoff = fd / sizeof(unsigned int);
8034
8035     if (sockflagsize && fdoff <= sockflagsize)
8036       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8037   }
8038   return fclose(fp);
8039 }
8040 /*}}}*/
8041
8042
8043 /*
8044  * A simple fwrite replacement which outputs itmsz*nitm chars without
8045  * introducing record boundaries every itmsz chars.
8046  * We are using fputs, which depends on a terminating null.  We may
8047  * well be writing binary data, so we need to accommodate not only
8048  * data with nulls sprinkled in the middle but also data with no null
8049  * byte at the end.
8050  */
8051 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8052 int
8053 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8054 {
8055   register char *cp, *end, *cpd, *data;
8056   register unsigned int fd = fileno(dest);
8057   register unsigned int fdoff = fd / sizeof(unsigned int);
8058   int retval;
8059   int bufsize = itmsz * nitm + 1;
8060
8061   if (fdoff < sockflagsize &&
8062       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8063     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8064     return nitm;
8065   }
8066
8067   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8068   memcpy( data, src, itmsz*nitm );
8069   data[itmsz*nitm] = '\0';
8070
8071   end = data + itmsz * nitm;
8072   retval = (int) nitm; /* on success return # items written */
8073
8074   cpd = data;
8075   while (cpd <= end) {
8076     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8077     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8078     if (cp < end)
8079       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8080     cpd = cp + 1;
8081   }
8082
8083   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8084   return retval;
8085
8086 }  /* end of my_fwrite() */
8087 /*}}}*/
8088
8089 /*{{{ int my_flush(FILE *fp)*/
8090 int
8091 Perl_my_flush(pTHX_ FILE *fp)
8092 {
8093     int res;
8094     if ((res = fflush(fp)) == 0 && fp) {
8095 #ifdef VMS_DO_SOCKETS
8096         Stat_t s;
8097         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8098 #endif
8099             res = fsync(fileno(fp));
8100     }
8101 /*
8102  * If the flush succeeded but set end-of-file, we need to clear
8103  * the error because our caller may check ferror().  BTW, this
8104  * probably means we just flushed an empty file.
8105  */
8106     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8107
8108     return res;
8109 }
8110 /*}}}*/
8111
8112 /*
8113  * Here are replacements for the following Unix routines in the VMS environment:
8114  *      getpwuid    Get information for a particular UIC or UID
8115  *      getpwnam    Get information for a named user
8116  *      getpwent    Get information for each user in the rights database
8117  *      setpwent    Reset search to the start of the rights database
8118  *      endpwent    Finish searching for users in the rights database
8119  *
8120  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8121  * (defined in pwd.h), which contains the following fields:-
8122  *      struct passwd {
8123  *              char        *pw_name;    Username (in lower case)
8124  *              char        *pw_passwd;  Hashed password
8125  *              unsigned int pw_uid;     UIC
8126  *              unsigned int pw_gid;     UIC group  number
8127  *              char        *pw_unixdir; Default device/directory (VMS-style)
8128  *              char        *pw_gecos;   Owner name
8129  *              char        *pw_dir;     Default device/directory (Unix-style)
8130  *              char        *pw_shell;   Default CLI name (eg. DCL)
8131  *      };
8132  * If the specified user does not exist, getpwuid and getpwnam return NULL.
8133  *
8134  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8135  * not the UIC member number (eg. what's returned by getuid()),
8136  * getpwuid() can accept either as input (if uid is specified, the caller's
8137  * UIC group is used), though it won't recognise gid=0.
8138  *
8139  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8140  * information about other users in your group or in other groups, respectively.
8141  * If the required privilege is not available, then these routines fill only
8142  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8143  * string).
8144  *
8145  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8146  */
8147
8148 /* sizes of various UAF record fields */
8149 #define UAI$S_USERNAME 12
8150 #define UAI$S_IDENT    31
8151 #define UAI$S_OWNER    31
8152 #define UAI$S_DEFDEV   31
8153 #define UAI$S_DEFDIR   63
8154 #define UAI$S_DEFCLI   31
8155 #define UAI$S_PWD       8
8156
8157 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
8158                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8159                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
8160
8161 static char __empty[]= "";
8162 static struct passwd __passwd_empty=
8163     {(char *) __empty, (char *) __empty, 0, 0,
8164      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8165 static int contxt= 0;
8166 static struct passwd __pwdcache;
8167 static char __pw_namecache[UAI$S_IDENT+1];
8168
8169 /*
8170  * This routine does most of the work extracting the user information.
8171  */
8172 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8173 {
8174     static struct {
8175         unsigned char length;
8176         char pw_gecos[UAI$S_OWNER+1];
8177     } owner;
8178     static union uicdef uic;
8179     static struct {
8180         unsigned char length;
8181         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8182     } defdev;
8183     static struct {
8184         unsigned char length;
8185         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8186     } defdir;
8187     static struct {
8188         unsigned char length;
8189         char pw_shell[UAI$S_DEFCLI+1];
8190     } defcli;
8191     static char pw_passwd[UAI$S_PWD+1];
8192
8193     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8194     struct dsc$descriptor_s name_desc;
8195     unsigned long int sts;
8196
8197     static struct itmlst_3 itmlst[]= {
8198         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
8199         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
8200         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
8201         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
8202         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
8203         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
8204         {0,                0,           NULL,    NULL}};
8205
8206     name_desc.dsc$w_length=  strlen(name);
8207     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8208     name_desc.dsc$b_class=   DSC$K_CLASS_S;
8209     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8210
8211 /*  Note that sys$getuai returns many fields as counted strings. */
8212     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8213     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8214       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8215     }
8216     else { _ckvmssts(sts); }
8217     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
8218
8219     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
8220     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8221     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8222     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8223     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8224     owner.pw_gecos[lowner]=            '\0';
8225     defdev.pw_dir[ldefdev+ldefdir]= '\0';
8226     defcli.pw_shell[ldefcli]=          '\0';
8227     if (valid_uic(uic)) {
8228         pwd->pw_uid= uic.uic$l_uic;
8229         pwd->pw_gid= uic.uic$v_group;
8230     }
8231     else
8232       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8233     pwd->pw_passwd=  pw_passwd;
8234     pwd->pw_gecos=   owner.pw_gecos;
8235     pwd->pw_dir=     defdev.pw_dir;
8236     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8237     pwd->pw_shell=   defcli.pw_shell;
8238     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8239         int ldir;
8240         ldir= strlen(pwd->pw_unixdir) - 1;
8241         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8242     }
8243     else
8244         strcpy(pwd->pw_unixdir, pwd->pw_dir);
8245     if (!decc_efs_case_preserve)
8246         __mystrtolower(pwd->pw_unixdir);
8247     return 1;
8248 }
8249
8250 /*
8251  * Get information for a named user.
8252 */
8253 /*{{{struct passwd *getpwnam(char *name)*/
8254 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8255 {
8256     struct dsc$descriptor_s name_desc;
8257     union uicdef uic;
8258     unsigned long int status, sts;
8259
8260     __pwdcache = __passwd_empty;
8261     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8262       /* We still may be able to determine pw_uid and pw_gid */
8263       name_desc.dsc$w_length=  strlen(name);
8264       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
8265       name_desc.dsc$b_class=   DSC$K_CLASS_S;
8266       name_desc.dsc$a_pointer= (char *) name;
8267       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
8268         __pwdcache.pw_uid= uic.uic$l_uic;
8269         __pwdcache.pw_gid= uic.uic$v_group;
8270       }
8271       else {
8272         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8273           set_vaxc_errno(sts);
8274           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
8275           return NULL;
8276         }
8277         else { _ckvmssts(sts); }
8278       }
8279     }
8280     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8281     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8282     __pwdcache.pw_name= __pw_namecache;
8283     return &__pwdcache;
8284 }  /* end of my_getpwnam() */
8285 /*}}}*/
8286
8287 /*
8288  * Get information for a particular UIC or UID.
8289  * Called by my_getpwent with uid=-1 to list all users.
8290 */
8291 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
8292 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
8293 {
8294     const $DESCRIPTOR(name_desc,__pw_namecache);
8295     unsigned short lname;
8296     union uicdef uic;
8297     unsigned long int status;
8298
8299     if (uid == (unsigned int) -1) {
8300       do {
8301         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
8302         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
8303           set_vaxc_errno(status);
8304           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8305           my_endpwent();
8306           return NULL;
8307         }
8308         else { _ckvmssts(status); }
8309       } while (!valid_uic (uic));
8310     }
8311     else {
8312       uic.uic$l_uic= uid;
8313       if (!uic.uic$v_group)
8314         uic.uic$v_group= PerlProc_getgid();
8315       if (valid_uic(uic))
8316         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
8317       else status = SS$_IVIDENT;
8318       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
8319           status == RMS$_PRV) {
8320         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8321         return NULL;
8322       }
8323       else { _ckvmssts(status); }
8324     }
8325     __pw_namecache[lname]= '\0';
8326     __mystrtolower(__pw_namecache);
8327
8328     __pwdcache = __passwd_empty;
8329     __pwdcache.pw_name = __pw_namecache;
8330
8331 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
8332     The identifier's value is usually the UIC, but it doesn't have to be,
8333     so if we can, we let fillpasswd update this. */
8334     __pwdcache.pw_uid =  uic.uic$l_uic;
8335     __pwdcache.pw_gid =  uic.uic$v_group;
8336
8337     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
8338     return &__pwdcache;
8339
8340 }  /* end of my_getpwuid() */
8341 /*}}}*/
8342
8343 /*
8344  * Get information for next user.
8345 */
8346 /*{{{struct passwd *my_getpwent()*/
8347 struct passwd *Perl_my_getpwent(pTHX)
8348 {
8349     return (my_getpwuid((unsigned int) -1));
8350 }
8351 /*}}}*/
8352
8353 /*
8354  * Finish searching rights database for users.
8355 */
8356 /*{{{void my_endpwent()*/
8357 void Perl_my_endpwent(pTHX)
8358 {
8359     if (contxt) {
8360       _ckvmssts(sys$finish_rdb(&contxt));
8361       contxt= 0;
8362     }
8363 }
8364 /*}}}*/
8365
8366 #ifdef HOMEGROWN_POSIX_SIGNALS
8367   /* Signal handling routines, pulled into the core from POSIX.xs.
8368    *
8369    * We need these for threads, so they've been rolled into the core,
8370    * rather than left in POSIX.xs.
8371    *
8372    * (DRS, Oct 23, 1997)
8373    */
8374
8375   /* sigset_t is atomic under VMS, so these routines are easy */
8376 /*{{{int my_sigemptyset(sigset_t *) */
8377 int my_sigemptyset(sigset_t *set) {
8378     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8379     *set = 0; return 0;
8380 }
8381 /*}}}*/
8382
8383
8384 /*{{{int my_sigfillset(sigset_t *)*/
8385 int my_sigfillset(sigset_t *set) {
8386     int i;
8387     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8388     for (i = 0; i < NSIG; i++) *set |= (1 << i);
8389     return 0;
8390 }
8391 /*}}}*/
8392
8393
8394 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
8395 int my_sigaddset(sigset_t *set, int sig) {
8396     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8397     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8398     *set |= (1 << (sig - 1));
8399     return 0;
8400 }
8401 /*}}}*/
8402
8403
8404 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
8405 int my_sigdelset(sigset_t *set, int sig) {
8406     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8407     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8408     *set &= ~(1 << (sig - 1));
8409     return 0;
8410 }
8411 /*}}}*/
8412
8413
8414 /*{{{int my_sigismember(sigset_t *set, int sig)*/
8415 int my_sigismember(sigset_t *set, int sig) {
8416     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8417     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8418     return *set & (1 << (sig - 1));
8419 }
8420 /*}}}*/
8421
8422
8423 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
8424 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
8425     sigset_t tempmask;
8426
8427     /* If set and oset are both null, then things are badly wrong. Bail out. */
8428     if ((oset == NULL) && (set == NULL)) {
8429       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
8430       return -1;
8431     }
8432
8433     /* If set's null, then we're just handling a fetch. */
8434     if (set == NULL) {
8435         tempmask = sigblock(0);
8436     }
8437     else {
8438       switch (how) {
8439       case SIG_SETMASK:
8440         tempmask = sigsetmask(*set);
8441         break;
8442       case SIG_BLOCK:
8443         tempmask = sigblock(*set);
8444         break;
8445       case SIG_UNBLOCK:
8446         tempmask = sigblock(0);
8447         sigsetmask(*oset & ~tempmask);
8448         break;
8449       default:
8450         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8451         return -1;
8452       }
8453     }
8454
8455     /* Did they pass us an oset? If so, stick our holding mask into it */
8456     if (oset)
8457       *oset = tempmask;
8458
8459     return 0;
8460 }
8461 /*}}}*/
8462 #endif  /* HOMEGROWN_POSIX_SIGNALS */
8463
8464
8465 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
8466  * my_utime(), and flex_stat(), all of which operate on UTC unless
8467  * VMSISH_TIMES is true.
8468  */
8469 /* method used to handle UTC conversions:
8470  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
8471  */
8472 static int gmtime_emulation_type;
8473 /* number of secs to add to UTC POSIX-style time to get local time */
8474 static long int utc_offset_secs;
8475
8476 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
8477  * in vmsish.h.  #undef them here so we can call the CRTL routines
8478  * directly.
8479  */
8480 #undef gmtime
8481 #undef localtime
8482 #undef time
8483
8484
8485 /*
8486  * DEC C previous to 6.0 corrupts the behavior of the /prefix
8487  * qualifier with the extern prefix pragma.  This provisional
8488  * hack circumvents this prefix pragma problem in previous
8489  * precompilers.
8490  */
8491 #if defined(__VMS_VER) && __VMS_VER >= 70000000
8492 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
8493 #    pragma __extern_prefix save
8494 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
8495 #    define gmtime decc$__utctz_gmtime
8496 #    define localtime decc$__utctz_localtime
8497 #    define time decc$__utc_time
8498 #    pragma __extern_prefix restore
8499
8500      struct tm *gmtime(), *localtime();
8501
8502 #  endif
8503 #endif
8504
8505
8506 static time_t toutc_dst(time_t loc) {
8507   struct tm *rsltmp;
8508
8509   if ((rsltmp = localtime(&loc)) == NULL) return -1;
8510   loc -= utc_offset_secs;
8511   if (rsltmp->tm_isdst) loc -= 3600;
8512   return loc;
8513 }
8514 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
8515        ((gmtime_emulation_type || my_time(NULL)), \
8516        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
8517        ((secs) - utc_offset_secs))))
8518
8519 static time_t toloc_dst(time_t utc) {
8520   struct tm *rsltmp;
8521
8522   utc += utc_offset_secs;
8523   if ((rsltmp = localtime(&utc)) == NULL) return -1;
8524   if (rsltmp->tm_isdst) utc += 3600;
8525   return utc;
8526 }
8527 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
8528        ((gmtime_emulation_type || my_time(NULL)), \
8529        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
8530        ((secs) + utc_offset_secs))))
8531
8532 #ifndef RTL_USES_UTC
8533 /*
8534
8535     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
8536         DST starts on 1st sun of april      at 02:00  std time
8537             ends on last sun of october     at 02:00  dst time
8538     see the UCX management command reference, SET CONFIG TIMEZONE
8539     for formatting info.
8540
8541     No, it's not as general as it should be, but then again, NOTHING
8542     will handle UK times in a sensible way.
8543 */
8544
8545
8546 /*
8547     parse the DST start/end info:
8548     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
8549 */
8550
8551 static char *
8552 tz_parse_startend(char *s, struct tm *w, int *past)
8553 {
8554     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
8555     int ly, dozjd, d, m, n, hour, min, sec, j, k;
8556     time_t g;
8557
8558     if (!s)    return 0;
8559     if (!w) return 0;
8560     if (!past) return 0;
8561
8562     ly = 0;
8563     if (w->tm_year % 4        == 0) ly = 1;
8564     if (w->tm_year % 100      == 0) ly = 0;
8565     if (w->tm_year+1900 % 400 == 0) ly = 1;
8566     if (ly) dinm[1]++;
8567
8568     dozjd = isdigit(*s);
8569     if (*s == 'J' || *s == 'j' || dozjd) {
8570         if (!dozjd && !isdigit(*++s)) return 0;
8571         d = *s++ - '0';
8572         if (isdigit(*s)) {
8573             d = d*10 + *s++ - '0';
8574             if (isdigit(*s)) {
8575                 d = d*10 + *s++ - '0';
8576             }
8577         }
8578         if (d == 0) return 0;
8579         if (d > 366) return 0;
8580         d--;
8581         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
8582         g = d * 86400;
8583         dozjd = 1;
8584     } else if (*s == 'M' || *s == 'm') {
8585         if (!isdigit(*++s)) return 0;
8586         m = *s++ - '0';
8587         if (isdigit(*s)) m = 10*m + *s++ - '0';
8588         if (*s != '.') return 0;
8589         if (!isdigit(*++s)) return 0;
8590         n = *s++ - '0';
8591         if (n < 1 || n > 5) return 0;
8592         if (*s != '.') return 0;
8593         if (!isdigit(*++s)) return 0;
8594         d = *s++ - '0';
8595         if (d > 6) return 0;
8596     }
8597
8598     if (*s == '/') {
8599         if (!isdigit(*++s)) return 0;
8600         hour = *s++ - '0';
8601         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
8602         if (*s == ':') {
8603             if (!isdigit(*++s)) return 0;
8604             min = *s++ - '0';
8605             if (isdigit(*s)) min = 10*min + *s++ - '0';
8606             if (*s == ':') {
8607                 if (!isdigit(*++s)) return 0;
8608                 sec = *s++ - '0';
8609                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
8610             }
8611         }
8612     } else {
8613         hour = 2;
8614         min = 0;
8615         sec = 0;
8616     }
8617
8618     if (dozjd) {
8619         if (w->tm_yday < d) goto before;
8620         if (w->tm_yday > d) goto after;
8621     } else {
8622         if (w->tm_mon+1 < m) goto before;
8623         if (w->tm_mon+1 > m) goto after;
8624
8625         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
8626         k = d - j; /* mday of first d */
8627         if (k <= 0) k += 7;
8628         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
8629         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
8630         if (w->tm_mday < k) goto before;
8631         if (w->tm_mday > k) goto after;
8632     }
8633
8634     if (w->tm_hour < hour) goto before;
8635     if (w->tm_hour > hour) goto after;
8636     if (w->tm_min  < min)  goto before;
8637     if (w->tm_min  > min)  goto after;
8638     if (w->tm_sec  < sec)  goto before;
8639     goto after;
8640
8641 before:
8642     *past = 0;
8643     return s;
8644 after:
8645     *past = 1;
8646     return s;
8647 }
8648
8649
8650
8651
8652 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
8653
8654 static char *
8655 tz_parse_offset(char *s, int *offset)
8656 {
8657     int hour = 0, min = 0, sec = 0;
8658     int neg = 0;
8659     if (!s) return 0;
8660     if (!offset) return 0;
8661
8662     if (*s == '-') {neg++; s++;}
8663     if (*s == '+') s++;
8664     if (!isdigit(*s)) return 0;
8665     hour = *s++ - '0';
8666     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
8667     if (hour > 24) return 0;
8668     if (*s == ':') {
8669         if (!isdigit(*++s)) return 0;
8670         min = *s++ - '0';
8671         if (isdigit(*s)) min = min*10 + (*s++ - '0');
8672         if (min > 59) return 0;
8673         if (*s == ':') {
8674             if (!isdigit(*++s)) return 0;
8675             sec = *s++ - '0';
8676             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
8677             if (sec > 59) return 0;
8678         }
8679     }
8680
8681     *offset = (hour*60+min)*60 + sec;
8682     if (neg) *offset = -*offset;
8683     return s;
8684 }
8685
8686 /*
8687     input time is w, whatever type of time the CRTL localtime() uses.
8688     sets dst, the zone, and the gmtoff (seconds)
8689
8690     caches the value of TZ and UCX$TZ env variables; note that
8691     my_setenv looks for these and sets a flag if they're changed
8692     for efficiency.
8693
8694     We have to watch out for the "australian" case (dst starts in
8695     october, ends in april)...flagged by "reverse" and checked by
8696     scanning through the months of the previous year.
8697
8698 */
8699
8700 static int
8701 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
8702 {
8703     time_t when;
8704     struct tm *w2;
8705     char *s,*s2;
8706     char *dstzone, *tz, *s_start, *s_end;
8707     int std_off, dst_off, isdst;
8708     int y, dststart, dstend;
8709     static char envtz[1025];  /* longer than any logical, symbol, ... */
8710     static char ucxtz[1025];
8711     static char reversed = 0;
8712
8713     if (!w) return 0;
8714
8715     if (tz_updated) {
8716         tz_updated = 0;
8717         reversed = -1;  /* flag need to check  */
8718         envtz[0] = ucxtz[0] = '\0';
8719         tz = my_getenv("TZ",0);
8720         if (tz) strcpy(envtz, tz);
8721         tz = my_getenv("UCX$TZ",0);
8722         if (tz) strcpy(ucxtz, tz);
8723         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
8724     }
8725     tz = envtz;
8726     if (!*tz) tz = ucxtz;
8727
8728     s = tz;
8729     while (isalpha(*s)) s++;
8730     s = tz_parse_offset(s, &std_off);
8731     if (!s) return 0;
8732     if (!*s) {                  /* no DST, hurray we're done! */
8733         isdst = 0;
8734         goto done;
8735     }
8736
8737     dstzone = s;
8738     while (isalpha(*s)) s++;
8739     s2 = tz_parse_offset(s, &dst_off);
8740     if (s2) {
8741         s = s2;
8742     } else {
8743         dst_off = std_off - 3600;
8744     }
8745
8746     if (!*s) {      /* default dst start/end?? */
8747         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
8748             s = strchr(ucxtz,',');
8749         }
8750         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
8751     }
8752     if (*s != ',') return 0;
8753
8754     when = *w;
8755     when = _toutc(when);      /* convert to utc */
8756     when = when - std_off;    /* convert to pseudolocal time*/
8757
8758     w2 = localtime(&when);
8759     y = w2->tm_year;
8760     s_start = s+1;
8761     s = tz_parse_startend(s_start,w2,&dststart);
8762     if (!s) return 0;
8763     if (*s != ',') return 0;
8764
8765     when = *w;
8766     when = _toutc(when);      /* convert to utc */
8767     when = when - dst_off;    /* convert to pseudolocal time*/
8768     w2 = localtime(&when);
8769     if (w2->tm_year != y) {   /* spans a year, just check one time */
8770         when += dst_off - std_off;
8771         w2 = localtime(&when);
8772     }
8773     s_end = s+1;
8774     s = tz_parse_startend(s_end,w2,&dstend);
8775     if (!s) return 0;
8776
8777     if (reversed == -1) {  /* need to check if start later than end */
8778         int j, ds, de;
8779
8780         when = *w;
8781         if (when < 2*365*86400) {
8782             when += 2*365*86400;
8783         } else {
8784             when -= 365*86400;
8785         }
8786         w2 =localtime(&when);
8787         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
8788
8789         for (j = 0; j < 12; j++) {
8790             w2 =localtime(&when);
8791             tz_parse_startend(s_start,w2,&ds);
8792             tz_parse_startend(s_end,w2,&de);
8793             if (ds != de) break;
8794             when += 30*86400;
8795         }
8796         reversed = 0;
8797         if (de && !ds) reversed = 1;
8798     }
8799
8800     isdst = dststart && !dstend;
8801     if (reversed) isdst = dststart  || !dstend;
8802
8803 done:
8804     if (dst)    *dst = isdst;
8805     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
8806     if (isdst)  tz = dstzone;
8807     if (zone) {
8808         while(isalpha(*tz))  *zone++ = *tz++;
8809         *zone = '\0';
8810     }
8811     return 1;
8812 }
8813
8814 #endif /* !RTL_USES_UTC */
8815
8816 /* my_time(), my_localtime(), my_gmtime()
8817  * By default traffic in UTC time values, using CRTL gmtime() or
8818  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
8819  * Note: We need to use these functions even when the CRTL has working
8820  * UTC support, since they also handle C<use vmsish qw(times);>
8821  *
8822  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
8823  * Modified by Charles Bailey <bailey@newman.upenn.edu>
8824  */
8825
8826 /*{{{time_t my_time(time_t *timep)*/
8827 time_t Perl_my_time(pTHX_ time_t *timep)
8828 {
8829   time_t when;
8830   struct tm *tm_p;
8831
8832   if (gmtime_emulation_type == 0) {
8833     int dstnow;
8834     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
8835                               /* results of calls to gmtime() and localtime() */
8836                               /* for same &base */
8837
8838     gmtime_emulation_type++;
8839     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
8840       char off[LNM$C_NAMLENGTH+1];;
8841
8842       gmtime_emulation_type++;
8843       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
8844         gmtime_emulation_type++;
8845         utc_offset_secs = 0;
8846         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
8847       }
8848       else { utc_offset_secs = atol(off); }
8849     }
8850     else { /* We've got a working gmtime() */
8851       struct tm gmt, local;
8852
8853       gmt = *tm_p;
8854       tm_p = localtime(&base);
8855       local = *tm_p;
8856       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
8857       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
8858       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
8859       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
8860     }
8861   }
8862
8863   when = time(NULL);
8864 # ifdef VMSISH_TIME
8865 # ifdef RTL_USES_UTC
8866   if (VMSISH_TIME) when = _toloc(when);
8867 # else
8868   if (!VMSISH_TIME) when = _toutc(when);
8869 # endif
8870 # endif
8871   if (timep != NULL) *timep = when;
8872   return when;
8873
8874 }  /* end of my_time() */
8875 /*}}}*/
8876
8877
8878 /*{{{struct tm *my_gmtime(const time_t *timep)*/
8879 struct tm *
8880 Perl_my_gmtime(pTHX_ const time_t *timep)
8881 {
8882   char *p;
8883   time_t when;
8884   struct tm *rsltmp;
8885
8886   if (timep == NULL) {
8887     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8888     return NULL;
8889   }
8890   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
8891
8892   when = *timep;
8893 # ifdef VMSISH_TIME
8894   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
8895 #  endif
8896 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
8897   return gmtime(&when);
8898 # else
8899   /* CRTL localtime() wants local time as input, so does no tz correction */
8900   rsltmp = localtime(&when);
8901   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
8902   return rsltmp;
8903 #endif
8904 }  /* end of my_gmtime() */
8905 /*}}}*/
8906
8907
8908 /*{{{struct tm *my_localtime(const time_t *timep)*/
8909 struct tm *
8910 Perl_my_localtime(pTHX_ const time_t *timep)
8911 {
8912   time_t when, whenutc;
8913   struct tm *rsltmp;
8914   int dst, offset;
8915
8916   if (timep == NULL) {
8917     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8918     return NULL;
8919   }
8920   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
8921   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
8922
8923   when = *timep;
8924 # ifdef RTL_USES_UTC
8925 # ifdef VMSISH_TIME
8926   if (VMSISH_TIME) when = _toutc(when);
8927 # endif
8928   /* CRTL localtime() wants UTC as input, does tz correction itself */
8929   return localtime(&when);
8930
8931 # else /* !RTL_USES_UTC */
8932   whenutc = when;
8933 # ifdef VMSISH_TIME
8934   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
8935   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
8936 # endif
8937   dst = -1;
8938 #ifndef RTL_USES_UTC
8939   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
8940       when = whenutc - offset;                   /* pseudolocal time*/
8941   }
8942 # endif
8943   /* CRTL localtime() wants local time as input, so does no tz correction */
8944   rsltmp = localtime(&when);
8945   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
8946   return rsltmp;
8947 # endif
8948
8949 } /*  end of my_localtime() */
8950 /*}}}*/
8951
8952 /* Reset definitions for later calls */
8953 #define gmtime(t)    my_gmtime(t)
8954 #define localtime(t) my_localtime(t)
8955 #define time(t)      my_time(t)
8956
8957
8958 /* my_utime - update modification time of a file
8959  * calling sequence is identical to POSIX utime(), but under
8960  * VMS only the modification time is changed; ODS-2 does not
8961  * maintain access times.  Restrictions differ from the POSIX
8962  * definition in that the time can be changed as long as the
8963  * caller has permission to execute the necessary IO$_MODIFY $QIO;
8964  * no separate checks are made to insure that the caller is the
8965  * owner of the file or has special privs enabled.
8966  * Code here is based on Joe Meadows' FILE utility.
8967  */
8968
8969 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
8970  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
8971  * in 100 ns intervals.
8972  */
8973 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
8974
8975 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
8976 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
8977 {
8978   register int i;
8979   int sts;
8980   long int bintime[2], len = 2, lowbit, unixtime,
8981            secscale = 10000000; /* seconds --> 100 ns intervals */
8982   unsigned long int chan, iosb[2], retsts;
8983   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
8984   struct FAB myfab = cc$rms_fab;
8985   struct NAM mynam = cc$rms_nam;
8986 #if defined (__DECC) && defined (__VAX)
8987   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
8988    * at least through VMS V6.1, which causes a type-conversion warning.
8989    */
8990 #  pragma message save
8991 #  pragma message disable cvtdiftypes
8992 #endif
8993   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
8994   struct fibdef myfib;
8995 #if defined (__DECC) && defined (__VAX)
8996   /* This should be right after the declaration of myatr, but due
8997    * to a bug in VAX DEC C, this takes effect a statement early.
8998    */
8999 #  pragma message restore
9000 #endif
9001   /* cast ok for read only parameter */
9002   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9003                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9004                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9005
9006   if (file == NULL || *file == '\0') {
9007     set_errno(ENOENT);
9008     set_vaxc_errno(LIB$_INVARG);
9009     return -1;
9010   }
9011   if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
9012
9013   if (utimes != NULL) {
9014     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
9015      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9016      * Since time_t is unsigned long int, and lib$emul takes a signed long int
9017      * as input, we force the sign bit to be clear by shifting unixtime right
9018      * one bit, then multiplying by an extra factor of 2 in lib$emul().
9019      */
9020     lowbit = (utimes->modtime & 1) ? secscale : 0;
9021     unixtime = (long int) utimes->modtime;
9022 #   ifdef VMSISH_TIME
9023     /* If input was UTC; convert to local for sys svc */
9024     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9025 #   endif
9026     unixtime >>= 1;  secscale <<= 1;
9027     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9028     if (!(retsts & 1)) {
9029       set_errno(EVMSERR);
9030       set_vaxc_errno(retsts);
9031       return -1;
9032     }
9033     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9034     if (!(retsts & 1)) {
9035       set_errno(EVMSERR);
9036       set_vaxc_errno(retsts);
9037       return -1;
9038     }
9039   }
9040   else {
9041     /* Just get the current time in VMS format directly */
9042     retsts = sys$gettim(bintime);
9043     if (!(retsts & 1)) {
9044       set_errno(EVMSERR);
9045       set_vaxc_errno(retsts);
9046       return -1;
9047     }
9048   }
9049
9050   myfab.fab$l_fna = vmsspec;
9051   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9052   myfab.fab$l_nam = &mynam;
9053   mynam.nam$l_esa = esa;
9054   mynam.nam$b_ess = (unsigned char) sizeof esa;
9055   mynam.nam$l_rsa = rsa;
9056   mynam.nam$b_rss = (unsigned char) sizeof rsa;
9057   if (decc_efs_case_preserve)
9058       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9059
9060   /* Look for the file to be affected, letting RMS parse the file
9061    * specification for us as well.  I have set errno using only
9062    * values documented in the utime() man page for VMS POSIX.
9063    */
9064   retsts = sys$parse(&myfab,0,0);
9065   if (!(retsts & 1)) {
9066     set_vaxc_errno(retsts);
9067     if      (retsts == RMS$_PRV) set_errno(EACCES);
9068     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9069     else                         set_errno(EVMSERR);
9070     return -1;
9071   }
9072   retsts = sys$search(&myfab,0,0);
9073   if (!(retsts & 1)) {
9074     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9075     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9076     set_vaxc_errno(retsts);
9077     if      (retsts == RMS$_PRV) set_errno(EACCES);
9078     else if (retsts == RMS$_FNF) set_errno(ENOENT);
9079     else                         set_errno(EVMSERR);
9080     return -1;
9081   }
9082
9083   devdsc.dsc$w_length = mynam.nam$b_dev;
9084   /* cast ok for read only parameter */
9085   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9086
9087   retsts = sys$assign(&devdsc,&chan,0,0);
9088   if (!(retsts & 1)) {
9089     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9090     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9091     set_vaxc_errno(retsts);
9092     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
9093     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
9094     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
9095     else                               set_errno(EVMSERR);
9096     return -1;
9097   }
9098
9099   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9100   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9101
9102   memset((void *) &myfib, 0, sizeof myfib);
9103 #if defined(__DECC) || defined(__DECCXX)
9104   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9105   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9106   /* This prevents the revision time of the file being reset to the current
9107    * time as a result of our IO$_MODIFY $QIO. */
9108   myfib.fib$l_acctl = FIB$M_NORECORD;
9109 #else
9110   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9111   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9112   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9113 #endif
9114   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9115   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
9116   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
9117   _ckvmssts(sys$dassgn(chan));
9118   if (retsts & 1) retsts = iosb[0];
9119   if (!(retsts & 1)) {
9120     set_vaxc_errno(retsts);
9121     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9122     else                      set_errno(EVMSERR);
9123     return -1;
9124   }
9125
9126   return 0;
9127 }  /* end of my_utime() */
9128 /*}}}*/
9129
9130 /*
9131  * flex_stat, flex_lstat, flex_fstat
9132  * basic stat, but gets it right when asked to stat
9133  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9134  */
9135
9136 #ifndef _USE_STD_STAT
9137 /* encode_dev packs a VMS device name string into an integer to allow
9138  * simple comparisons. This can be used, for example, to check whether two
9139  * files are located on the same device, by comparing their encoded device
9140  * names. Even a string comparison would not do, because stat() reuses the
9141  * device name buffer for each call; so without encode_dev, it would be
9142  * necessary to save the buffer and use strcmp (this would mean a number of
9143  * changes to the standard Perl code, to say nothing of what a Perl script
9144  * would have to do.
9145  *
9146  * The device lock id, if it exists, should be unique (unless perhaps compared
9147  * with lock ids transferred from other nodes). We have a lock id if the disk is
9148  * mounted cluster-wide, which is when we tend to get long (host-qualified)
9149  * device names. Thus we use the lock id in preference, and only if that isn't
9150  * available, do we try to pack the device name into an integer (flagged by
9151  * the sign bit (LOCKID_MASK) being set).
9152  *
9153  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9154  * name and its encoded form, but it seems very unlikely that we will find
9155  * two files on different disks that share the same encoded device names,
9156  * and even more remote that they will share the same file id (if the test
9157  * is to check for the same file).
9158  *
9159  * A better method might be to use sys$device_scan on the first call, and to
9160  * search for the device, returning an index into the cached array.
9161  * The number returned would be more intelligable.
9162  * This is probably not worth it, and anyway would take quite a bit longer
9163  * on the first call.
9164  */
9165 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
9166 static mydev_t encode_dev (pTHX_ const char *dev)
9167 {
9168   int i;
9169   unsigned long int f;
9170   mydev_t enc;
9171   char c;
9172   const char *q;
9173
9174   if (!dev || !dev[0]) return 0;
9175
9176 #if LOCKID_MASK
9177   {
9178     struct dsc$descriptor_s dev_desc;
9179     unsigned long int status, lockid, item = DVI$_LOCKID;
9180
9181     /* For cluster-mounted disks, the disk lock identifier is unique, so we
9182        can try that first. */
9183     dev_desc.dsc$w_length =  strlen (dev);
9184     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
9185     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
9186     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
9187     _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9188     if (lockid) return (lockid & ~LOCKID_MASK);
9189   }
9190 #endif
9191
9192   /* Otherwise we try to encode the device name */
9193   enc = 0;
9194   f = 1;
9195   i = 0;
9196   for (q = dev + strlen(dev); q--; q >= dev) {
9197     if (isdigit (*q))
9198       c= (*q) - '0';
9199     else if (isalpha (toupper (*q)))
9200       c= toupper (*q) - 'A' + (char)10;
9201     else
9202       continue; /* Skip '$'s */
9203     i++;
9204     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
9205     if (i>1) f *= 36;
9206     enc += f * (unsigned long int) c;
9207   }
9208   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
9209
9210 }  /* end of encode_dev() */
9211 #endif
9212
9213 static char namecache[NAM$C_MAXRSS+1];
9214
9215 static int
9216 is_null_device(name)
9217     const char *name;
9218 {
9219   if (decc_bug_devnull != 0) {
9220     if (strcmp("/dev/null", name) == 0) /* temp hack */
9221       return 1;
9222   }
9223     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9224        The underscore prefix, controller letter, and unit number are
9225        independently optional; for our purposes, the colon punctuation
9226        is not.  The colon can be trailed by optional directory and/or
9227        filename, but two consecutive colons indicates a nodename rather
9228        than a device.  [pr]  */
9229   if (*name == '_') ++name;
9230   if (tolower(*name++) != 'n') return 0;
9231   if (tolower(*name++) != 'l') return 0;
9232   if (tolower(*name) == 'a') ++name;
9233   if (*name == '0') ++name;
9234   return (*name++ == ':') && (*name != ':');
9235 }
9236
9237 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
9238 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9239  * subset of the applicable information.
9240  */
9241 bool
9242 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
9243 {
9244   char fname_phdev[NAM$C_MAXRSS+1];
9245 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9246   /* Namecache not workable with symbolic links, as symbolic links do
9247    *  not have extensions and directories do in VMS mode.  So in order
9248    *  to test this, the did and ino_t must be used.
9249    *
9250    * Fix-me - Hide the information in the new stat structure
9251    *          Get rid of the namecache.
9252    */
9253   if (decc_posix_compliant_pathnames == 0)
9254 #endif
9255       if (statbufp == &PL_statcache)
9256           return cando_by_name(bit,effective,namecache);
9257   {
9258     char fname[NAM$C_MAXRSS+1];
9259     unsigned long int retsts;
9260     struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9261                             namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9262
9263     /* If the struct mystat is stale, we're OOL; stat() overwrites the
9264        device name on successive calls */
9265     devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
9266     devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
9267     namdsc.dsc$a_pointer = fname;
9268     namdsc.dsc$w_length = sizeof fname - 1;
9269
9270     retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
9271                              &namdsc,&namdsc.dsc$w_length,0,0);
9272     if (retsts & 1) {
9273       fname[namdsc.dsc$w_length] = '\0';
9274 /*
9275  * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
9276  * but if someone has redefined that logical, Perl gets very lost.  Since
9277  * we have the physical device name from the stat buffer, just paste it on.
9278  */
9279       strcpy( fname_phdev, statbufp->st_devnam );
9280       strcat( fname_phdev, strrchr(fname, ':') );
9281
9282       return cando_by_name(bit,effective,fname_phdev);
9283     }
9284     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
9285       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
9286       return FALSE;
9287     }
9288     _ckvmssts(retsts);
9289     return FALSE;  /* Should never get to here */
9290   }
9291 }  /* end of cando() */
9292 /*}}}*/
9293
9294
9295 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
9296 I32
9297 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
9298 {
9299   static char usrname[L_cuserid];
9300   static struct dsc$descriptor_s usrdsc =
9301          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
9302   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
9303   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
9304   unsigned short int retlen, trnlnm_iter_count;
9305   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9306   union prvdef curprv;
9307   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9308          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
9309   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9310          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9311          {0,0,0,0}};
9312   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
9313          {0,0,0,0}};
9314   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9315
9316   if (!fname || !*fname) return FALSE;
9317   /* Make sure we expand logical names, since sys$check_access doesn't */
9318   if (!strpbrk(fname,"/]>:")) {
9319     strcpy(fileified,fname);
9320     trnlnm_iter_count = 0;
9321     while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
9322         trnlnm_iter_count++;
9323         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
9324     }
9325     fname = fileified;
9326   }
9327   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
9328   retlen = namdsc.dsc$w_length = strlen(vmsname);
9329   namdsc.dsc$a_pointer = vmsname;
9330   if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
9331       vmsname[retlen-1] == ':') {
9332     if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9333     namdsc.dsc$w_length = strlen(fileified);
9334     namdsc.dsc$a_pointer = fileified;
9335   }
9336
9337   switch (bit) {
9338     case S_IXUSR: case S_IXGRP: case S_IXOTH:
9339       access = ARM$M_EXECUTE; break;
9340     case S_IRUSR: case S_IRGRP: case S_IROTH:
9341       access = ARM$M_READ; break;
9342     case S_IWUSR: case S_IWGRP: case S_IWOTH:
9343       access = ARM$M_WRITE; break;
9344     case S_IDUSR: case S_IDGRP: case S_IDOTH:
9345       access = ARM$M_DELETE; break;
9346     default:
9347       return FALSE;
9348   }
9349
9350   /* Before we call $check_access, create a user profile with the current
9351    * process privs since otherwise it just uses the default privs from the
9352    * UAF and might give false positives or negatives.  This only works on
9353    * VMS versions v6.0 and later since that's when sys$create_user_profile
9354    * became available.
9355    */
9356
9357   /* get current process privs and username */
9358   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9359   _ckvmssts(iosb[0]);
9360
9361 #if defined(__VMS_VER) && __VMS_VER >= 60000000
9362
9363   /* find out the space required for the profile */
9364   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
9365                                     &usrprodsc.dsc$w_length,0));
9366
9367   /* allocate space for the profile and get it filled in */
9368   Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
9369   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
9370                                     &usrprodsc.dsc$w_length,0));
9371
9372   /* use the profile to check access to the file; free profile & analyze results */
9373   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
9374   Safefree(usrprodsc.dsc$a_pointer);
9375   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
9376
9377 #else
9378
9379   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
9380
9381 #endif
9382
9383   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
9384       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
9385       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
9386     set_vaxc_errno(retsts);
9387     if (retsts == SS$_NOPRIV) set_errno(EACCES);
9388     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
9389     else set_errno(ENOENT);
9390     return FALSE;
9391   }
9392   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
9393     return TRUE;
9394   }
9395   _ckvmssts(retsts);
9396
9397   return FALSE;  /* Should never get here */
9398
9399 }  /* end of cando_by_name() */
9400 /*}}}*/
9401
9402
9403 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
9404 int
9405 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
9406 {
9407   if (!fstat(fd,(stat_t *) statbufp)) {
9408     if (statbufp == (Stat_t *) &PL_statcache) {
9409     char *cptr;
9410
9411         /* Save name for cando by name in VMS format */
9412         cptr = getname(fd, namecache, 1);
9413
9414         /* This should not happen, but just in case */
9415         if (cptr == NULL)
9416            namecache[0] = '\0';
9417     }
9418 #ifdef _USE_STD_STAT
9419     memcpy(&statbufp->st_ino, &statbufp->crtl_stat.st_ino, 8);
9420 #else
9421     memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9422 #endif
9423 #ifndef _USE_STD_STAT
9424     strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9425     statbufp->st_devnam[63] = 0;
9426     statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9427 #else
9428     /* todo:
9429      * The device is only encoded so that Perl_cando can use it to
9430      * look up ACLS.  So rmsexpand it to the 255 character version
9431      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9432      * for long filenames and symbolic links first.  This also seems
9433      * to remove the need for a namecache that could be stale.
9434      */
9435 #endif
9436
9437 #   ifdef RTL_USES_UTC
9438 #   ifdef VMSISH_TIME
9439     if (VMSISH_TIME) {
9440       statbufp->st_mtime = _toloc(statbufp->st_mtime);
9441       statbufp->st_atime = _toloc(statbufp->st_atime);
9442       statbufp->st_ctime = _toloc(statbufp->st_ctime);
9443     }
9444 #   endif
9445 #   else
9446 #   ifdef VMSISH_TIME
9447     if (!VMSISH_TIME) { /* Return UTC instead of local time */
9448 #   else
9449     if (1) {
9450 #   endif
9451       statbufp->st_mtime = _toutc(statbufp->st_mtime);
9452       statbufp->st_atime = _toutc(statbufp->st_atime);
9453       statbufp->st_ctime = _toutc(statbufp->st_ctime);
9454     }
9455 #endif
9456     return 0;
9457   }
9458   return -1;
9459
9460 }  /* end of flex_fstat() */
9461 /*}}}*/
9462
9463 #if !defined(__VAX) && __CRTL_VER >= 80200000
9464 #ifdef lstat
9465 #undef lstat
9466 #endif
9467 #else
9468 #ifdef lstat
9469 #undef lstat
9470 #endif
9471 #define lstat(_x, _y) stat(_x, _y)
9472 #endif
9473
9474 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
9475
9476 static int
9477 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
9478 {
9479     char fileified[NAM$C_MAXRSS+1];
9480     char temp_fspec[NAM$C_MAXRSS+300];
9481     int retval = -1;
9482     int saved_errno, saved_vaxc_errno;
9483
9484     if (!fspec) return retval;
9485     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
9486     strcpy(temp_fspec, fspec);
9487     if (statbufp == (Stat_t *) &PL_statcache)
9488       do_tovmsspec(temp_fspec,namecache,0);
9489     if (decc_bug_devnull != 0) {
9490       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
9491         memset(statbufp,0,sizeof *statbufp);
9492         statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
9493         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
9494         statbufp->st_uid = 0x00010001;
9495         statbufp->st_gid = 0x0001;
9496         time((time_t *)&statbufp->st_mtime);
9497         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
9498         return 0;
9499       }
9500     }
9501
9502     /* Try for a directory name first.  If fspec contains a filename without
9503      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9504      * and sea:[wine.dark]water. exist, we prefer the directory here.
9505      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
9506      * not sea:[wine.dark]., if the latter exists.  If the intended target is
9507      * the file with null type, specify this by calling flex_stat() with
9508      * a '.' at the end of fspec.
9509      *
9510      * If we are in Posix filespec mode, accept the filename as is.
9511      */
9512 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9513   if (decc_posix_compliant_pathnames == 0) {
9514 #endif
9515     if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
9516       if (lstat_flag == 0)
9517         retval = stat(fileified,(stat_t *) statbufp);
9518       else
9519         retval = lstat(fileified,(stat_t *) statbufp);
9520       if (!retval && statbufp == (Stat_t *) &PL_statcache)
9521         strcpy(namecache,fileified);
9522     }
9523     if (retval) {
9524       if (lstat_flag == 0)
9525         retval = stat(temp_fspec,(stat_t *) statbufp);
9526       else
9527         retval = lstat(temp_fspec,(stat_t *) statbufp);
9528     }
9529 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9530   } else {
9531     if (lstat_flag == 0)
9532       retval = stat(temp_fspec,(stat_t *) statbufp);
9533     else
9534       retval = lstat(temp_fspec,(stat_t *) statbufp);
9535   }
9536 #endif
9537     if (!retval) {
9538 #ifdef _USE_STD_STAT
9539       memcpy(&statbufp->st_ino, &statbufp->crtl_stat.st_ino, 8);
9540 #else
9541       memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9542 #endif
9543 #ifndef _USE_STD_STAT
9544       strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9545       statbufp->st_devnam[63] = 0;
9546       statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9547 #else
9548     /* todo:
9549      * The device is only encoded so that Perl_cando can use it to
9550      * look up ACLS.  So rmsexpand it to the 255 character version
9551      * and store it in ->st_devnam.  rmsexpand needs to be fixed
9552      * for long filenames and symbolic links first.  This also seems
9553      * to remove the need for a namecache that could be stale.
9554      */
9555 #endif
9556 #     ifdef RTL_USES_UTC
9557 #     ifdef VMSISH_TIME
9558       if (VMSISH_TIME) {
9559         statbufp->st_mtime = _toloc(statbufp->st_mtime);
9560         statbufp->st_atime = _toloc(statbufp->st_atime);
9561         statbufp->st_ctime = _toloc(statbufp->st_ctime);
9562       }
9563 #     endif
9564 #     else
9565 #     ifdef VMSISH_TIME
9566       if (!VMSISH_TIME) { /* Return UTC instead of local time */
9567 #     else
9568       if (1) {
9569 #     endif
9570         statbufp->st_mtime = _toutc(statbufp->st_mtime);
9571         statbufp->st_atime = _toutc(statbufp->st_atime);
9572         statbufp->st_ctime = _toutc(statbufp->st_ctime);
9573       }
9574 #     endif
9575     }
9576     /* If we were successful, leave errno where we found it */
9577     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
9578     return retval;
9579
9580 }  /* end of flex_stat_int() */
9581
9582
9583 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
9584 int
9585 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
9586 {
9587    return flex_stat_int(fspec, statbufp, 0);
9588 }
9589 /*}}}*/
9590
9591 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
9592 int
9593 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
9594 {
9595    return flex_stat_int(fspec, statbufp, 1);
9596 }
9597 /*}}}*/
9598
9599
9600 /*{{{char *my_getlogin()*/
9601 /* VMS cuserid == Unix getlogin, except calling sequence */
9602 char *
9603 my_getlogin(void)
9604 {
9605     static char user[L_cuserid];
9606     return cuserid(user);
9607 }
9608 /*}}}*/
9609
9610
9611 /*  rmscopy - copy a file using VMS RMS routines
9612  *
9613  *  Copies contents and attributes of spec_in to spec_out, except owner
9614  *  and protection information.  Name and type of spec_in are used as
9615  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
9616  *  should try to propagate timestamps from the input file to the output file.
9617  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
9618  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
9619  *  propagated to the output file at creation iff the output file specification
9620  *  did not contain an explicit name or type, and the revision date is always
9621  *  updated at the end of the copy operation.  If it is greater than 0, then
9622  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
9623  *  other than the revision date should be propagated, and bit 1 indicates
9624  *  that the revision date should be propagated.
9625  *
9626  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
9627  *
9628  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
9629  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
9630  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
9631  * as part of the Perl standard distribution under the terms of the
9632  * GNU General Public License or the Perl Artistic License.  Copies
9633  * of each may be found in the Perl standard distribution.
9634  */
9635 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
9636 int
9637 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
9638 {
9639     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
9640          rsa[NAM$C_MAXRSS], ubf[32256];
9641     unsigned long int i, sts, sts2;
9642     struct FAB fab_in, fab_out;
9643     struct RAB rab_in, rab_out;
9644     struct NAM nam;
9645     struct XABDAT xabdat;
9646     struct XABFHC xabfhc;
9647     struct XABRDT xabrdt;
9648     struct XABSUM xabsum;
9649
9650     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1) ||
9651         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
9652       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9653       return 0;
9654     }
9655
9656     fab_in = cc$rms_fab;
9657     fab_in.fab$l_fna = vmsin;
9658     fab_in.fab$b_fns = strlen(vmsin);
9659     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
9660     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
9661     fab_in.fab$l_fop = FAB$M_SQO;
9662     fab_in.fab$l_nam =  &nam;
9663     fab_in.fab$l_xab = (void *) &xabdat;
9664
9665     nam = cc$rms_nam;
9666     nam.nam$l_rsa = rsa;
9667     nam.nam$b_rss = sizeof(rsa);
9668     nam.nam$l_esa = esa;
9669     nam.nam$b_ess = sizeof (esa);
9670     nam.nam$b_esl = nam.nam$b_rsl = 0;
9671 #ifdef NAM$M_NO_SHORT_UPCASE
9672     if (decc_efs_case_preserve)
9673         nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9674 #endif
9675
9676     xabdat = cc$rms_xabdat;        /* To get creation date */
9677     xabdat.xab$l_nxt = (void *) &xabfhc;
9678
9679     xabfhc = cc$rms_xabfhc;        /* To get record length */
9680     xabfhc.xab$l_nxt = (void *) &xabsum;
9681
9682     xabsum = cc$rms_xabsum;        /* To get key and area information */
9683
9684     if (!((sts = sys$open(&fab_in)) & 1)) {
9685       set_vaxc_errno(sts);
9686       switch (sts) {
9687         case RMS$_FNF: case RMS$_DNF:
9688           set_errno(ENOENT); break;
9689         case RMS$_DIR:
9690           set_errno(ENOTDIR); break;
9691         case RMS$_DEV:
9692           set_errno(ENODEV); break;
9693         case RMS$_SYN:
9694           set_errno(EINVAL); break;
9695         case RMS$_PRV:
9696           set_errno(EACCES); break;
9697         default:
9698           set_errno(EVMSERR);
9699       }
9700       return 0;
9701     }
9702
9703     fab_out = fab_in;
9704     fab_out.fab$w_ifi = 0;
9705     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
9706     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
9707     fab_out.fab$l_fop = FAB$M_SQO;
9708     fab_out.fab$l_fna = vmsout;
9709     fab_out.fab$b_fns = strlen(vmsout);
9710     fab_out.fab$l_dna = nam.nam$l_name;
9711     fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
9712
9713     if (preserve_dates == 0) {  /* Act like DCL COPY */
9714       nam.nam$b_nop |= NAM$M_SYNCHK;
9715       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
9716       if (!((sts = sys$parse(&fab_out)) & 1)) {
9717         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
9718         set_vaxc_errno(sts);
9719         return 0;
9720       }
9721       fab_out.fab$l_xab = (void *) &xabdat;
9722       if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
9723     }
9724     fab_out.fab$l_nam = (void *) 0;  /* Done with NAM block */
9725     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
9726       preserve_dates =0;      /* bitmask from this point forward   */
9727
9728     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
9729     if (!((sts = sys$create(&fab_out)) & 1)) {
9730       set_vaxc_errno(sts);
9731       switch (sts) {
9732         case RMS$_DNF:
9733           set_errno(ENOENT); break;
9734         case RMS$_DIR:
9735           set_errno(ENOTDIR); break;
9736         case RMS$_DEV:
9737           set_errno(ENODEV); break;
9738         case RMS$_SYN:
9739           set_errno(EINVAL); break;
9740         case RMS$_PRV:
9741           set_errno(EACCES); break;
9742         default:
9743           set_errno(EVMSERR);
9744       }
9745       return 0;
9746     }
9747     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
9748     if (preserve_dates & 2) {
9749       /* sys$close() will process xabrdt, not xabdat */
9750       xabrdt = cc$rms_xabrdt;
9751 #ifndef __GNUC__
9752       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
9753 #else
9754       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
9755        * is unsigned long[2], while DECC & VAXC use a struct */
9756       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
9757 #endif
9758       fab_out.fab$l_xab = (void *) &xabrdt;
9759     }
9760
9761     rab_in = cc$rms_rab;
9762     rab_in.rab$l_fab = &fab_in;
9763     rab_in.rab$l_rop = RAB$M_BIO;
9764     rab_in.rab$l_ubf = ubf;
9765     rab_in.rab$w_usz = sizeof ubf;
9766     if (!((sts = sys$connect(&rab_in)) & 1)) {
9767       sys$close(&fab_in); sys$close(&fab_out);
9768       set_errno(EVMSERR); set_vaxc_errno(sts);
9769       return 0;
9770     }
9771
9772     rab_out = cc$rms_rab;
9773     rab_out.rab$l_fab = &fab_out;
9774     rab_out.rab$l_rbf = ubf;
9775     if (!((sts = sys$connect(&rab_out)) & 1)) {
9776       sys$close(&fab_in); sys$close(&fab_out);
9777       set_errno(EVMSERR); set_vaxc_errno(sts);
9778       return 0;
9779     }
9780
9781     while ((sts = sys$read(&rab_in))) {  /* always true  */
9782       if (sts == RMS$_EOF) break;
9783       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
9784       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
9785         sys$close(&fab_in); sys$close(&fab_out);
9786         set_errno(EVMSERR); set_vaxc_errno(sts);
9787         return 0;
9788       }
9789     }
9790
9791     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
9792     sys$close(&fab_in);  sys$close(&fab_out);
9793     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
9794     if (!(sts & 1)) {
9795       set_errno(EVMSERR); set_vaxc_errno(sts);
9796       return 0;
9797     }
9798
9799     return 1;
9800
9801 }  /* end of rmscopy() */
9802 /*}}}*/
9803
9804
9805 /***  The following glue provides 'hooks' to make some of the routines
9806  * from this file available from Perl.  These routines are sufficiently
9807  * basic, and are required sufficiently early in the build process,
9808  * that's it's nice to have them available to miniperl as well as the
9809  * full Perl, so they're set up here instead of in an extension.  The
9810  * Perl code which handles importation of these names into a given
9811  * package lives in [.VMS]Filespec.pm in @INC.
9812  */
9813
9814 void
9815 rmsexpand_fromperl(pTHX_ CV *cv)
9816 {
9817   dXSARGS;
9818   char *fspec, *defspec = NULL, *rslt;
9819   STRLEN n_a;
9820
9821   if (!items || items > 2)
9822     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
9823   fspec = SvPV(ST(0),n_a);
9824   if (!fspec || !*fspec) XSRETURN_UNDEF;
9825   if (items == 2) defspec = SvPV(ST(1),n_a);
9826
9827   rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
9828   ST(0) = sv_newmortal();
9829   if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
9830   XSRETURN(1);
9831 }
9832
9833 void
9834 vmsify_fromperl(pTHX_ CV *cv)
9835 {
9836   dXSARGS;
9837   char *vmsified;
9838   STRLEN n_a;
9839
9840   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
9841   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
9842   ST(0) = sv_newmortal();
9843   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
9844   XSRETURN(1);
9845 }
9846
9847 void
9848 unixify_fromperl(pTHX_ CV *cv)
9849 {
9850   dXSARGS;
9851   char *unixified;
9852   STRLEN n_a;
9853
9854   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
9855   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
9856   ST(0) = sv_newmortal();
9857   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
9858   XSRETURN(1);
9859 }
9860
9861 void
9862 fileify_fromperl(pTHX_ CV *cv)
9863 {
9864   dXSARGS;
9865   char *fileified;
9866   STRLEN n_a;
9867
9868   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
9869   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
9870   ST(0) = sv_newmortal();
9871   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
9872   XSRETURN(1);
9873 }
9874
9875 void
9876 pathify_fromperl(pTHX_ CV *cv)
9877 {
9878   dXSARGS;
9879   char *pathified;
9880   STRLEN n_a;
9881
9882   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
9883   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
9884   ST(0) = sv_newmortal();
9885   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
9886   XSRETURN(1);
9887 }
9888
9889 void
9890 vmspath_fromperl(pTHX_ CV *cv)
9891 {
9892   dXSARGS;
9893   char *vmspath;
9894   STRLEN n_a;
9895
9896   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
9897   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
9898   ST(0) = sv_newmortal();
9899   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
9900   XSRETURN(1);
9901 }
9902
9903 void
9904 unixpath_fromperl(pTHX_ CV *cv)
9905 {
9906   dXSARGS;
9907   char *unixpath;
9908   STRLEN n_a;
9909
9910   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
9911   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
9912   ST(0) = sv_newmortal();
9913   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
9914   XSRETURN(1);
9915 }
9916
9917 void
9918 candelete_fromperl(pTHX_ CV *cv)
9919 {
9920   dXSARGS;
9921   char fspec[NAM$C_MAXRSS+1], *fsp;
9922   SV *mysv;
9923   IO *io;
9924   STRLEN n_a;
9925
9926   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
9927
9928   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
9929   if (SvTYPE(mysv) == SVt_PVGV) {
9930     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
9931       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9932       ST(0) = &PL_sv_no;
9933       XSRETURN(1);
9934     }
9935     fsp = fspec;
9936   }
9937   else {
9938     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
9939       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9940       ST(0) = &PL_sv_no;
9941       XSRETURN(1);
9942     }
9943   }
9944
9945   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
9946   XSRETURN(1);
9947 }
9948
9949 void
9950 rmscopy_fromperl(pTHX_ CV *cv)
9951 {
9952   dXSARGS;
9953   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
9954   int date_flag;
9955   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9956                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9957   unsigned long int sts;
9958   SV *mysv;
9959   IO *io;
9960   STRLEN n_a;
9961
9962   if (items < 2 || items > 3)
9963     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
9964
9965   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
9966   if (SvTYPE(mysv) == SVt_PVGV) {
9967     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
9968       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9969       ST(0) = &PL_sv_no;
9970       XSRETURN(1);
9971     }
9972     inp = inspec;
9973   }
9974   else {
9975     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
9976       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9977       ST(0) = &PL_sv_no;
9978       XSRETURN(1);
9979     }
9980   }
9981   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
9982   if (SvTYPE(mysv) == SVt_PVGV) {
9983     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
9984       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9985       ST(0) = &PL_sv_no;
9986       XSRETURN(1);
9987     }
9988     outp = outspec;
9989   }
9990   else {
9991     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
9992       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9993       ST(0) = &PL_sv_no;
9994       XSRETURN(1);
9995     }
9996   }
9997   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
9998
9999   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
10000   XSRETURN(1);
10001 }
10002
10003
10004 void
10005 mod2fname(pTHX_ CV *cv)
10006 {
10007   dXSARGS;
10008   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10009        workbuff[NAM$C_MAXRSS*1 + 1];
10010   int total_namelen = 3, counter, num_entries;
10011   /* ODS-5 ups this, but we want to be consistent, so... */
10012   int max_name_len = 39;
10013   AV *in_array = (AV *)SvRV(ST(0));
10014
10015   num_entries = av_len(in_array);
10016
10017   /* All the names start with PL_. */
10018   strcpy(ultimate_name, "PL_");
10019
10020   /* Clean up our working buffer */
10021   Zero(work_name, sizeof(work_name), char);
10022
10023   /* Run through the entries and build up a working name */
10024   for(counter = 0; counter <= num_entries; counter++) {
10025     /* If it's not the first name then tack on a __ */
10026     if (counter) {
10027       strcat(work_name, "__");
10028     }
10029     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10030                            PL_na));
10031   }
10032
10033   /* Check to see if we actually have to bother...*/
10034   if (strlen(work_name) + 3 <= max_name_len) {
10035     strcat(ultimate_name, work_name);
10036   } else {
10037     /* It's too darned big, so we need to go strip. We use the same */
10038     /* algorithm as xsubpp does. First, strip out doubled __ */
10039     char *source, *dest, last;
10040     dest = workbuff;
10041     last = 0;
10042     for (source = work_name; *source; source++) {
10043       if (last == *source && last == '_') {
10044         continue;
10045       }
10046       *dest++ = *source;
10047       last = *source;
10048     }
10049     /* Go put it back */
10050     strcpy(work_name, workbuff);
10051     /* Is it still too big? */
10052     if (strlen(work_name) + 3 > max_name_len) {
10053       /* Strip duplicate letters */
10054       last = 0;
10055       dest = workbuff;
10056       for (source = work_name; *source; source++) {
10057         if (last == toupper(*source)) {
10058         continue;
10059         }
10060         *dest++ = *source;
10061         last = toupper(*source);
10062       }
10063       strcpy(work_name, workbuff);
10064     }
10065
10066     /* Is it *still* too big? */
10067     if (strlen(work_name) + 3 > max_name_len) {
10068       /* Too bad, we truncate */
10069       work_name[max_name_len - 2] = 0;
10070     }
10071     strcat(ultimate_name, work_name);
10072   }
10073
10074   /* Okay, return it */
10075   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10076   XSRETURN(1);
10077 }
10078
10079 void
10080 hushexit_fromperl(pTHX_ CV *cv)
10081 {
10082     dXSARGS;
10083
10084     if (items > 0) {
10085         VMSISH_HUSHED = SvTRUE(ST(0));
10086     }
10087     ST(0) = boolSV(VMSISH_HUSHED);
10088     XSRETURN(1);
10089 }
10090
10091 #ifdef HAS_SYMLINK
10092 static char *
10093 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10094
10095 void
10096 vms_realpath_fromperl(pTHX_ CV *cv)
10097 {
10098   dXSARGS;
10099   char *fspec, *rslt_spec, *rslt;
10100   STRLEN n_a;
10101
10102   if (!items || items != 1)
10103     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
10104
10105   fspec = SvPV(ST(0),n_a);
10106   if (!fspec || !*fspec) XSRETURN_UNDEF;
10107
10108   Newx(rslt_spec, VMS_MAXRSS + 1, char);
10109   rslt = do_vms_realpath(fspec, rslt_spec);
10110   ST(0) = sv_newmortal();
10111   if (rslt != NULL)
10112     sv_usepvn(ST(0),rslt,strlen(rslt));
10113   else
10114     Safefree(rslt_spec);
10115   XSRETURN(1);
10116 }
10117 #endif
10118
10119 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10120 int do_vms_case_tolerant(void);
10121
10122 void
10123 vms_case_tolerant_fromperl(pTHX_ CV *cv)
10124 {
10125   dXSARGS;
10126   ST(0) = boolSV(do_vms_case_tolerant());
10127   XSRETURN(1);
10128 }
10129 #endif
10130
10131 void
10132 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
10133                           struct interp_intern *dst)
10134 {
10135     memcpy(dst,src,sizeof(struct interp_intern));
10136 }
10137
10138 void
10139 Perl_sys_intern_clear(pTHX)
10140 {
10141 }
10142
10143 void
10144 Perl_sys_intern_init(pTHX)
10145 {
10146     unsigned int ix = RAND_MAX;
10147     double x;
10148
10149     VMSISH_HUSHED = 0;
10150
10151     /* fix me later to track running under GNV */
10152     /* this allows some limited testing */
10153     MY_POSIX_EXIT = decc_filename_unix_report;
10154
10155     x = (float)ix;
10156     MY_INV_RAND_MAX = 1./x;
10157 }
10158
10159 void
10160 init_os_extras(void)
10161 {
10162   dTHX;
10163   char* file = __FILE__;
10164   char temp_buff[512];
10165   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
10166     no_translate_barewords = TRUE;
10167   } else {
10168     no_translate_barewords = FALSE;
10169   }
10170
10171   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
10172   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
10173   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
10174   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
10175   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
10176   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
10177   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
10178   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
10179   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
10180   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
10181   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
10182 #ifdef HAS_SYMLINK
10183   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
10184 #endif
10185 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10186   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
10187 #endif
10188
10189   store_pipelocs(aTHX);         /* will redo any earlier attempts */
10190
10191   return;
10192 }
10193
10194 #ifdef HAS_SYMLINK
10195
10196 #if __CRTL_VER == 80200000
10197 /* This missed getting in to the DECC SDK for 8.2 */
10198 char *realpath(const char *file_name, char * resolved_name, ...);
10199 #endif
10200
10201 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
10202 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
10203  * The perl fallback routine to provide realpath() is not as efficient
10204  * on OpenVMS.
10205  */
10206 static char *
10207 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10208 {
10209     return realpath(filespec, outbuf);
10210 }
10211
10212 /*}}}*/
10213 /* External entry points */
10214 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10215 { return do_vms_realpath(filespec, outbuf); }
10216 #else
10217 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10218 { return NULL; }
10219 #endif
10220
10221
10222 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10223 /* case_tolerant */
10224
10225 /*{{{int do_vms_case_tolerant(void)*/
10226 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
10227  * controlled by a process setting.
10228  */
10229 int do_vms_case_tolerant(void)
10230 {
10231     return vms_process_case_tolerant;
10232 }
10233 /*}}}*/
10234 /* External entry points */
10235 int Perl_vms_case_tolerant(void)
10236 { return do_vms_case_tolerant(); }
10237 #else
10238 int Perl_vms_case_tolerant(void)
10239 { return vms_process_case_tolerant; }
10240 #endif
10241
10242
10243  /* Start of DECC RTL Feature handling */
10244
10245 static int sys_trnlnm
10246    (const char * logname,
10247     char * value,
10248     int value_len)
10249 {
10250     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
10251     const unsigned long attr = LNM$M_CASE_BLIND;
10252     struct dsc$descriptor_s name_dsc;
10253     int status;
10254     unsigned short result;
10255     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
10256                                 {0, 0, 0, 0}};
10257
10258     name_dsc.dsc$w_length = strlen(logname);
10259     name_dsc.dsc$a_pointer = (char *)logname;
10260     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10261     name_dsc.dsc$b_class = DSC$K_CLASS_S;
10262
10263     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
10264
10265     if ($VMS_STATUS_SUCCESS(status)) {
10266
10267          /* Null terminate and return the string */
10268         /*--------------------------------------*/
10269         value[result] = 0;
10270     }
10271
10272     return status;
10273 }
10274
10275 static int sys_crelnm
10276    (const char * logname,
10277     const char * value)
10278 {
10279     int ret_val;
10280     const char * proc_table = "LNM$PROCESS_TABLE";
10281     struct dsc$descriptor_s proc_table_dsc;
10282     struct dsc$descriptor_s logname_dsc;
10283     struct itmlst_3 item_list[2];
10284
10285     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
10286     proc_table_dsc.dsc$w_length = strlen(proc_table);
10287     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10288     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
10289
10290     logname_dsc.dsc$a_pointer = (char *) logname;
10291     logname_dsc.dsc$w_length = strlen(logname);
10292     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10293     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
10294
10295     item_list[0].buflen = strlen(value);
10296     item_list[0].itmcode = LNM$_STRING;
10297     item_list[0].bufadr = (char *)value;
10298     item_list[0].retlen = NULL;
10299
10300     item_list[1].buflen = 0;
10301     item_list[1].itmcode = 0;
10302
10303     ret_val = sys$crelnm
10304                        (NULL,
10305                         (const struct dsc$descriptor_s *)&proc_table_dsc,
10306                         (const struct dsc$descriptor_s *)&logname_dsc,
10307                         NULL,
10308                         (const struct item_list_3 *) item_list);
10309
10310     return ret_val;
10311 }
10312
10313
10314 /* C RTL Feature settings */
10315
10316 static int set_features
10317    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
10318     int (* cli_routine)(void),  /* Not documented */
10319     void *image_info)           /* Not documented */
10320 {
10321     int status;
10322     int s;
10323     int dflt;
10324     char* str;
10325     char val_str[10];
10326     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
10327     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
10328     unsigned long case_perm;
10329     unsigned long case_image;
10330
10331     /* hacks to see if known bugs are still present for testing */
10332
10333     /* Readdir is returning filenames in VMS syntax always */
10334     decc_bug_readdir_efs1 = 1;
10335     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
10336     if ($VMS_STATUS_SUCCESS(status)) {
10337        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10338          decc_bug_readdir_efs1 = 1;
10339        else
10340          decc_bug_readdir_efs1 = 0;
10341     }
10342
10343     /* PCP mode requires creating /dev/null special device file */
10344     decc_bug_devnull = 0;
10345     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
10346     if ($VMS_STATUS_SUCCESS(status)) {
10347        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10348           decc_bug_devnull = 1;
10349     }
10350
10351     /* fgetname returning a VMS name in UNIX mode */
10352     decc_bug_fgetname = 1;
10353     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
10354     if ($VMS_STATUS_SUCCESS(status)) {
10355       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10356         decc_bug_fgetname = 1;
10357       else
10358         decc_bug_fgetname = 0;
10359     }
10360
10361     /* UNIX directory names with no paths are broken in a lot of places */
10362     decc_dir_barename = 1;
10363     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
10364     if ($VMS_STATUS_SUCCESS(status)) {
10365       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10366         decc_dir_barename = 1;
10367       else
10368         decc_dir_barename = 0;
10369     }
10370
10371 #if __CRTL_VER >= 70300000 && !defined(__VAX)
10372     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
10373     if (s >= 0) {
10374         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
10375         if (decc_disable_to_vms_logname_translation < 0)
10376             decc_disable_to_vms_logname_translation = 0;
10377     }
10378
10379     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
10380     if (s >= 0) {
10381         decc_efs_case_preserve = decc$feature_get_value(s, 1);
10382         if (decc_efs_case_preserve < 0)
10383             decc_efs_case_preserve = 0;
10384     }
10385
10386     s = decc$feature_get_index("DECC$EFS_CHARSET");
10387     if (s >= 0) {
10388         decc_efs_charset = decc$feature_get_value(s, 1);
10389         if (decc_efs_charset < 0)
10390             decc_efs_charset = 0;
10391     }
10392
10393     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
10394     if (s >= 0) {
10395         decc_filename_unix_report = decc$feature_get_value(s, 1);
10396         if (decc_filename_unix_report > 0)
10397             decc_filename_unix_report = 1;
10398         else
10399             decc_filename_unix_report = 0;
10400     }
10401
10402     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
10403     if (s >= 0) {
10404         decc_filename_unix_only = decc$feature_get_value(s, 1);
10405         if (decc_filename_unix_only > 0) {
10406             decc_filename_unix_only = 1;
10407         }
10408         else {
10409             decc_filename_unix_only = 0;
10410         }
10411     }
10412
10413     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
10414     if (s >= 0) {
10415         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
10416         if (decc_filename_unix_no_version < 0)
10417             decc_filename_unix_no_version = 0;
10418     }
10419
10420     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
10421     if (s >= 0) {
10422         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
10423         if (decc_readdir_dropdotnotype < 0)
10424             decc_readdir_dropdotnotype = 0;
10425     }
10426
10427     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
10428     if ($VMS_STATUS_SUCCESS(status)) {
10429         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
10430         if (s >= 0) {
10431             dflt = decc$feature_get_value(s, 4);
10432             if (dflt > 0) {
10433                 decc_disable_posix_root = decc$feature_get_value(s, 1);
10434                 if (decc_disable_posix_root <= 0) {
10435                     decc$feature_set_value(s, 1, 1);
10436                     decc_disable_posix_root = 1;
10437                 }
10438             }
10439             else {
10440                 /* Traditionally Perl assumes this is off */
10441                 decc_disable_posix_root = 1;
10442                 decc$feature_set_value(s, 1, 1);
10443             }
10444         }
10445     }
10446
10447 #if __CRTL_VER >= 80200000
10448     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
10449     if (s >= 0) {
10450         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
10451         if (decc_posix_compliant_pathnames < 0)
10452             decc_posix_compliant_pathnames = 0;
10453         if (decc_posix_compliant_pathnames > 4)
10454             decc_posix_compliant_pathnames = 0;
10455     }
10456
10457 #endif
10458 #else
10459     status = sys_trnlnm
10460         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
10461     if ($VMS_STATUS_SUCCESS(status)) {
10462         val_str[0] = _toupper(val_str[0]);
10463         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10464            decc_disable_to_vms_logname_translation = 1;
10465         }
10466     }
10467
10468 #ifndef __VAX
10469     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
10470     if ($VMS_STATUS_SUCCESS(status)) {
10471         val_str[0] = _toupper(val_str[0]);
10472         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10473            decc_efs_case_preserve = 1;
10474         }
10475     }
10476 #endif
10477
10478     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
10479     if ($VMS_STATUS_SUCCESS(status)) {
10480         val_str[0] = _toupper(val_str[0]);
10481         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10482            decc_filename_unix_report = 1;
10483         }
10484     }
10485     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
10486     if ($VMS_STATUS_SUCCESS(status)) {
10487         val_str[0] = _toupper(val_str[0]);
10488         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10489            decc_filename_unix_only = 1;
10490            decc_filename_unix_report = 1;
10491         }
10492     }
10493     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
10494     if ($VMS_STATUS_SUCCESS(status)) {
10495         val_str[0] = _toupper(val_str[0]);
10496         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10497            decc_filename_unix_no_version = 1;
10498         }
10499     }
10500     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
10501     if ($VMS_STATUS_SUCCESS(status)) {
10502         val_str[0] = _toupper(val_str[0]);
10503         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
10504            decc_readdir_dropdotnotype = 1;
10505         }
10506     }
10507 #endif
10508
10509 #ifndef __VAX
10510
10511      /* Report true case tolerance */
10512     /*----------------------------*/
10513     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
10514     if (!$VMS_STATUS_SUCCESS(status))
10515         case_perm = PPROP$K_CASE_BLIND;
10516     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
10517     if (!$VMS_STATUS_SUCCESS(status))
10518         case_image = PPROP$K_CASE_BLIND;
10519     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
10520         (case_image == PPROP$K_CASE_SENSITIVE))
10521         vms_process_case_tolerant = 0;
10522
10523 #endif
10524
10525
10526     /* CRTL can be initialized past this point, but not before. */
10527 /*    DECC$CRTL_INIT(); */
10528
10529     return SS$_NORMAL;
10530 }
10531
10532 #ifdef __DECC
10533 /* DECC dependent attributes */
10534 #if __DECC_VER < 60560002
10535 #define relative
10536 #define not_executable
10537 #else
10538 #define relative ,rel
10539 #define not_executable ,noexe
10540 #endif
10541 #pragma nostandard
10542 #pragma extern_model save
10543 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
10544 #endif
10545         const __align (LONGWORD) int spare[8] = {0};
10546 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
10547 /*                        NOWRT, LONG */
10548 #ifdef __DECC
10549 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
10550         nowrt,noshr relative not_executable
10551 #endif
10552 const long vms_cc_features = (const long)set_features;
10553
10554 /*
10555 ** Force a reference to LIB$INITIALIZE to ensure it
10556 ** exists in the image.
10557 */
10558 int lib$initialize(void);
10559 #ifdef __DECC
10560 #pragma extern_model strict_refdef
10561 #endif
10562     int lib_init_ref = (int) lib$initialize;
10563
10564 #ifdef __DECC
10565 #pragma extern_model restore
10566 #pragma standard
10567 #endif
10568
10569 /*  End of vms.c */