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